/*
 * Copyright (c) 2006-2009 BitMover, Inc.
 */
#include <stdio.h>
#include <stdarg.h>
#include <setjmp.h>
#include "tclInt.h"
#include "tclIO.h"
#include "tclCompile.h"
#include "tclRegexp.h"
#include "Lcompile.h"
#include "Lgrammar.h"

/* Used by compile_spawn_system(). */
enum {
	SYSTEM_ARGV		= 0x00000001,
	SYSTEM_IN_STRING	= 0x00000002,
	SYSTEM_IN_ARRAY		= 0x00000004,
	SYSTEM_IN_FILENAME	= 0x00000008,
	SYSTEM_IN_HANDLE	= 0x00000010,
	SYSTEM_OUT_STRING	= 0x00000020,
	SYSTEM_OUT_ARRAY	= 0x00000040,
	SYSTEM_OUT_FILENAME	= 0x00000080,
	SYSTEM_OUT_HANDLE	= 0x00000100,
	SYSTEM_ERR_STRING	= 0x00000200,
	SYSTEM_ERR_ARRAY	= 0x00000400,
	SYSTEM_ERR_FILENAME	= 0x00000800,
	SYSTEM_ERR_HANDLE	= 0x00001000,
	SYSTEM_BACKGROUND	= 0x00002000,
};

/*
 * As of March 2009, we use a bit in the Tcl_Obj structure to
 * represent when an object has the L undefined value.  This avoids
 * the problems we had when Tcl would shimmer undef away into another
 * type, making it look defined.  But we also need an undef object, as
 * the value of array, hash, and struct members when they dynamically
 * are brought into life.  This is also the value of the "undef"
 * pre-defined constant.  We create one object of this type and dup it
 * whenever undef is requested.
 */

private void
undef_freeInternalRep(Tcl_Obj *o)
{
}

/*
 * Return an error if someone tries to convert something to undef
 * type.
 */
private int
undef_setFromAny(Tcl_Interp *interp, Tcl_Obj *o)
{
	Tcl_SetObjResult(interp,
			 Tcl_NewStringObj("cannot convert to undefined value",
					  -1));
	return (TCL_ERROR);
}

/*
 * Get a pointer to the "undefined" object pointer, allocating it the
 * first time it is needed.  Keep the refCount high because we want
 * the one-and-only undef object to never be freed.
 */
Tcl_Obj **
L_undefObjPtrPtr()
{
	static Tcl_Obj *undef_obj = NULL;

	unless (undef_obj) {
		undef_obj = Tcl_NewObj();
		undef_obj->bytes    = tclEmptyStringRep;
		undef_obj->typePtr  = &L_undefType;
		undef_obj->undef    = 1;
		undef_obj->refCount = 1234;  // arbitrary; to be recognizable
	}
	ASSERT(undef_obj->undef);
	return (&undef_obj);
}

int
L_isUndef(Tcl_Obj *o)
{
	return (o->undef);
}

Tcl_ObjType L_undefType = {
	"undef",
	undef_freeInternalRep,
	NULL,
	NULL,
	undef_setFromAny
};

/* Returned by re_kind. */
typedef enum {
	RE_NOT_AN_RE	= 0x0001,
	RE_CONST	= 0x0002,
	RE_GLOB		= 0x0004,
	RE_SIMPLE	= 0x0008,
	RE_COMPLEX	= 0x0010,
	RE_NEEDS_EVAL	= 0x0020,
} ReKind;

/* Used by tmp_* API. */
typedef enum {
	TMP_REUSE,
	TMP_UNSET,
} TmpKind;

/*
 * Lists of allowable attributes in #pragma, _attribute, and cmd-line
 * options.  Each array must end with a NULL.
 */
char *L_attrs_attribute[] = {
	"dis",
	"fnhook",
	"fntrace",
	"trace_depth",
	NULL
};
char *L_attrs_cmdLine[] = {
	"L",
	"dis",
	"fnhook",
	"fntrace",
	"line",
	"lineadj",
	"norun",
	"nowarn",
	"poly",
	"trace_depth",
	"trace_files",
	"trace_funcs",
	"trace_out",
	"trace_script",
	"warn_undefined_fns",
	"version",
	NULL
};
char *L_attrs_pragma[] = {
	"dis",
	"fnhook",
	"fntrace",
	"line",
	"lineadj",
	"norun",
	"nowarn",
	"poly",
	"trace_depth",
	"warn_undefined_fns",
	NULL
};
char *L_attrs_Lhtml[] = {
	"line",
	"lineadj",
};

/* The next two functions are generated by flex. */
extern void	*L__scan_bytes (const char *bytes, int len);
extern void	L__delete_buffer(void *buf);

private int	ast_compile(void *ast);
private void	ast_free(Ast *ast_list);
private char	*basenm(char *s);
private int	compile_abs(Expr *expr);
private int	compile_assert(Expr *expr);
private void	compile_assign(Expr *expr);
private void	compile_assignComposite(Expr *expr);
private void	compile_assignFromStack(Expr *lhs, Type *rhs_type, Expr *expr,
					int flags);
private int	compile_binOp(Expr *expr, Expr_f flags);
private void	compile_block(Block *block);
private void	compile_break(Stmt *stmt);
private int	compile_cast(Expr *expr, Expr_f flags);
private int	compile_catch(Expr *expr);
private void	compile_clsDecl(ClsDecl *class);
private int	compile_clsDeref(Expr *expr, Expr_f flags);
private int	compile_clsInstDeref(Expr *expr, Expr_f flags);
private void	compile_condition(Expr *cond);
private void	compile_continue(Stmt *stmt);
private void	compile_defined(Expr *expr);
private int	compile_die(Expr *expr);
private void	compile_do(Loop *loop);
private void	compile_eq_stack(Expr *expr, Type *type);
private void	compile_for_while(Loop *loop);
private int	compile_idxOp(Expr *expr, Expr_f flags);
private int	compile_idxOp2(Expr *expr, Expr_f flags);
private int	compile_expr(Expr *expr, Expr_f flags);
private int	compile_exprs(Expr *expr, Expr_f flags);
private int	compile_fnCall(Expr *expr);
private void	compile_fnDecl(FnDecl *fun, Decl_f flags);
private void	compile_fnDecls(FnDecl *fun, Decl_f flags);
private void	compile_foreach(ForEach *loop);
private void	compile_foreachAngle(ForEach *loop);
private void	compile_foreachArray(ForEach *loop);
private void	compile_foreachHash(ForEach *loop);
private void	compile_foreachString(ForEach *loop);
private void	compile_goto(Stmt *stmt);
private int	compile_here(Expr *expr);
private void	compile_ifUnless(Cond *cond);
private void	compile_incdec(Expr *expr);
private int	compile_insert_unshift(Expr *expr);
private int	compile_join(Expr *expr);
private int	compile_keys(Expr *expr);
private void	compile_label(Stmt *stmt);
private int	compile_length(Expr *expr);
private void	compile_loop(Loop *loop);
private int	compile_min_max(Expr *expr);
private int	compile_fnParms(VarDecl *decl);
private int	compile_popen(Expr *expr);
private int	compile_pop_shift(Expr *expr);
private int	compile_push(Expr *expr);
private void	compile_reMatch(Expr *re);
private int	compile_read(Expr *expr);
private int	compile_rename(Expr *expr);
private void	compile_return(Stmt *stmt);
private int	compile_script(Tcl_Obj *scriptObj, Tcl_Obj *nameObj);
private void	compile_shortCircuit(Expr *expr);
private int	compile_sort(Expr *expr);
private int	compile_spawn_system(Expr *expr);
private int	compile_split(Expr *expr);
private void	compile_stmt(Stmt *stmt);
private void	compile_stmts(Stmt *stmt);
private void	compile_switch(Switch *sw);
private void	compile_switch_fast(Switch *sw);
private void	compile_switch_slow(Switch *sw);
private int	compile_trinOp(Expr *expr);
private int	compile_trace_script(char *script);
private void	compile_trycatch(Stmt *stmt);
private void	compile_twiddle(Expr *expr);
private void	compile_twiddleSubst(Expr *expr);
private int	compile_typeof(Expr *expr);
private int	compile_undef(Expr *expr);
private int	compile_unOp(Expr *expr);
private int	compile_var(Expr *expr, Expr_f flags);
private void	compile_varDecl(VarDecl *decl);
private void	compile_varDecls(VarDecl *decls);
private int	compile_warn(Expr *expr);
private int	compile_write(Expr *expr);
private void	copyout_parms(Expr *actuals);
private Tcl_Obj	*do_getline(Tcl_Interp *interp, Tcl_Channel chan);
private void	emit_globalUpvar(Sym *sym);
private void	emit_instrForLOp(Expr *expr, Type *type);
private void	emit_jmp_back(TclJumpType jmp_type, int offset);
private Jmp	*emit_jmp_fwd(int op, Jmp *next);
private void	fixup_jmps(Jmp **jumps);
private int	fnCallBegin();
private void	fnCallEnd(int lev);
private int	fnInArgList();
private Frame	*frame_find(Frame_f flags);
private char	*frame_name(void);
private void	frame_pop(void);
private void	frame_push(void *node, char *name, Frame_f flags);
private void	frame_resumeBody();
private void	frame_resumePrologue();
private char	*get_text(Expr *expr);
private int	has_END(Expr *expr);
private void	init_predefined();
private Type	*iscallbyname(VarDecl *formal);
private int	ispatternfn(char *name, Expr **foo, Expr **Foo_star,
			    Expr **opts, int *nopts);
private Label	*label_lookup(Stmt *stmt, Label_f flags);
private Expr	*mkId(char *name);
private int	parse_options(int objc, Tcl_Obj **objv, char *allowed[]);
private int	parse_script(char *str, Ast **L_ast, Tcl_Obj *nameObj);
private void	proc_mkArg(Proc *proc, VarDecl *decl);
private int	push_index(Expr *expr, int flags);
private int	push_parms(Expr *actuals, VarDecl *formals);
private int	push_regexpModifiers(Expr *regexp);
private ReKind	re_kind(Expr *re, Tcl_DString *ds);
private int	re_submatchCnt(Expr *re);
private VarDecl	*struct_lookupMember(Type *t, Expr *idx, int *offset);
private Sym	*sym_mk(char *name, Type *t, Decl_f flags);
private Sym	*sym_lookup(Expr *id, Expr_f flags);
private Sym	*sym_store(VarDecl *decl);
private Tmp	*tmp_get(TmpKind kind);
private void	tmp_free(Tmp *tmp);
private void	tmp_freeAll(Tmp *tmp);
private void	track_cmd(int codeOffset, void *node);
private void	type_free(Type *type_list);
private int	typeck_spawn(Expr *in, Expr *out, Expr *err);
private int	typeck_system(Expr *in, Expr *out, Expr *err);

Linterp	*L;		// per-interp L state
Type	*L_int;		// pre-defined types
Type	*L_float;
Type	*L_string;
Type	*L_void;
Type	*L_var;
Type	*L_poly;
Type	*L_widget;

/*
 * L built-in functions.
 */
static struct {
	char	*name;
	int	(*fn)(Expr *);
} builtins[] = {
	{ "abs",	compile_abs },
	{ "assert",	compile_assert },
	{ "catch",	compile_catch },
	{ "die",	compile_die },
	{ "here",	compile_here },
	{ "insert",	compile_insert_unshift },
	{ "join",	compile_join },
	{ "keys",	compile_keys },
	{ "length",	compile_length },
	{ "max",	compile_min_max },
	{ "min",	compile_min_max },
	{ "popen",	compile_popen },
	{ "pop",	compile_pop_shift },
	{ "push",	compile_push },
	{ "read",	compile_read },
	{ "rename",	compile_rename },
	{ "shift",	compile_pop_shift },
	{ "sort",	compile_sort },
	{ "split",	compile_split },
	{ "spawn",	compile_spawn_system },
	{ "system",	compile_spawn_system },
	{ "typeof",	compile_typeof },
	{ "undef",	compile_undef },
	{ "unshift",	compile_insert_unshift },
	{ "warn",	compile_warn },
	{ "write",	compile_write },
};

/*
 * L compiler entry point.
 */
int
Tcl_LObjCmd(ClientData clientData, Tcl_Interp *interp, int objc,
	    Tcl_Obj *CONST objv[])
{
	char	*s;
	int	argc, ret;
	Tcl_Obj	**argvList;

	/* Extract the L state from the interp. */
	L = Tcl_GetAssocData(interp, "L", NULL);

	/*
	 * Verify that lib L was loaded.  L fails badly if lib L isn't
	 * there, and this catches cases where the user overrides the
	 * Tcl library path.
	 */
	unless (Tcl_GetVar(L->interp, "::L_libl_initted", 0)) {
		Tcl_SetResult(L->interp, "fatal -- libl.tcl not found", 0);
		return (TCL_ERROR);
	}

	if (objc < 2) {
		Tcl_WrongNumArgs(interp, 1, objv, "?options? l-program");
		return (TCL_ERROR);
	}

	/* Parse options from both the Tcl L command and the tclsh cmd line. */
	L->errs = NULL;
	L->options = Tcl_NewDictObj();
	ret = parse_options(objc-1, (Tcl_Obj **)(objv+1), L_attrs_cmdLine);
	unless (ret == TCL_OK) {
		Tcl_SetObjResult(interp, L->errs);
		return (ret);
	}
	if (L->global->tclsh_argv &&
	    Tcl_ListObjGetElements(L->interp, L->global->tclsh_argv, &argc,
				   &argvList) == TCL_OK) {
		ret = parse_options(argc-1, argvList+1, L_attrs_cmdLine);
		unless (ret == TCL_OK) {
			Tcl_SetObjResult(interp, L->errs);
			return (ret);
		}
	}

	/* L_synerr() longjmps back here on a parser syntax error. */
	if (setjmp(L->jmp)) {
		Tcl_SetObjResult(interp, L->errs);
		return (TCL_ERROR);
	}

	/*
	 * If a function-tracing script was specified in
	 * --trace_script or L_TRACE_SCRIPT (takes precedence),
	 * compile that (once) but only after libL has been compiled.
	 */
	unless (hash_get(L->options, "trace_script_compiled")) {
		if ((s = getenv("L_TRACE_SCRIPT"))) {
			hash_put(L->options, "trace_script", s);
		}
		if ((s = hash_get(L->options, "trace_script")) &&
		    Tcl_GetVar(L->interp, "::L_libl_done", 0)) {
			hash_put(L->options, "trace_script_compiled", "yes");
			s = ckstrdup(s);
			ret = compile_trace_script(s);
			if (ret != TCL_OK) return (ret);
		}
	}

	/*
	 * Propagate some cmd-line options to env variables for lib L.
	 * Pre-existing env variables take precedence.
	 */
	if ((s = hash_get(L->options, "trace_funcs"))) {
		unless (getenv("L_TRACE_FUNCS")) {
			s = cksprintf("L_TRACE_FUNCS=%s", s);
			putenv(s);
		}
	}
	if ((s = hash_get(L->options, "trace_files"))) {
		unless (getenv("L_TRACE_FILES")) {
			s = cksprintf("L_TRACE_FILES=%s", s);
			putenv(s);
		}
	}
	if ((s = hash_get(L->options, "trace_out"))) {
		unless (getenv("L_TRACE_OUT")) {
			s = cksprintf("L_TRACE_OUT=%s", s);
			putenv(s);
		}
	}
	if ((s = hash_get(L->options, "fnhook"))) {
		unless (getenv("L_TRACE_HOOK")) {
			s = cksprintf("L_TRACE_HOOK=%s", s);
			putenv(s);
		}
	}
	if ((s = hash_get(L->options, "fntrace"))) {
		unless (getenv("L_TRACE_ALL")) {
			s = cksprintf("L_TRACE_ALL=%s", s);
			putenv(s);
		}
	}
	if ((s = hash_get(L->options, "dis"))) {
		unless (getenv("L_DISASSEMBLE")) {
			s = cksprintf("L_DISASSEMBLE=%s", s);
			putenv(s);
		}
	}

	/* This allows the old comparison-op syntax (eq ne lt le gt ge). */
	if (getenv("_L_ALLOW_EQ_OPS")) {
		hash_put(L->options, "allow_eq_ops", "yes");
	}

	return (compile_script(objv[objc-1], ((Interp *)L->interp)->scriptFile));
}

private int
compile_trace_script(char *script)
{
	int		len, ret;
	Tcl_Channel	chan;
	Tcl_Obj		*nameObj, *scriptObj;

	len = strlen(script);
	if ((len > 3) && (script[len-2] == '.') && (script[len-1] == 'l')) {
		nameObj = Tcl_NewStringObj(script, -1);
		Tcl_IncrRefCount(nameObj);
		chan = Tcl_FSOpenFileChannel(L->interp, nameObj, "r", 0644);
		unless (chan) return (TCL_ERROR);
		scriptObj = Tcl_NewObj();
		Tcl_IncrRefCount(scriptObj);
		ret = Tcl_ReadChars(chan, scriptObj, -1, 0);
		Tcl_Close(L->interp, chan);
		if (ret < 0) {
			Tcl_DecrRefCount(scriptObj);
			return (TCL_ERROR);
		}
	} else {
		nameObj = Tcl_NewStringObj("L_TRACE_SCRIPT", -1);
		scriptObj = Tcl_ObjPrintf(
		    "void L_fn_hook(_argused int pre, _argused poly av[], "
		    "_argused poly ret) { %s ;}",
		    script);
		hash_put(L->options, "fnhook", "L_fn_hook");
		Tcl_IncrRefCount(nameObj);
	}
	ret = compile_script(scriptObj, nameObj);
	Tcl_DecrRefCount(nameObj);
	return (ret);
}

private int
compile_script(Tcl_Obj *scriptObj, Tcl_Obj *nameObj)
{
	int	ret;
	Ast	*ast;
#ifdef TCL_COMPILE_DEBUG
	char	*s;
#endif

	L->script = Tcl_NewObj();
	Tcl_IncrRefCount(L->script);
	L->script_len = 0;

	ret = parse_script(TclGetString(scriptObj), &ast, nameObj);

	if ((ret == TCL_OK) && ast) {
		ret = ast_compile(ast);
	}

#ifdef TCL_COMPILE_DEBUG
	if ((s = getenv("L_TRACE_BYTECODES"))) {
		extern int tclTraceExec;
		tclTraceExec = atoi(s);
	}
#endif
	return (ret);
}

/*
 * Parse key=val (where =val is optional and is replaced by "yes" if
 * omitted) and add to the L->options hash.  Strip any leading -'s from
 * key so that -key and --key both work.  Replace all other -'s with _'s
 * so that --trace-files becomes trace_files.
 */
private int
parse_options(int objc, Tcl_Obj **objv, char *allowed[])
{
	int	i, ret = TCL_OK;
	char	*key, *newkey, *p, *val;
	char	**q;

	for (i = 0; i < objc; ++i) {
		key = Tcl_GetString(objv[i]);
		unless (key[0] == '-') break;
		/* Look for key=val */
		val = strchr(key, '=');
		if (val) {
			*val = 0;
		}
		newkey = ckalloc(strlen(key)+1);
		/* Skip past all leading -'s in the key */
		while (*key == '-') ++key;
		/* Now copy except replace all other -'s with _ */
		for (p = newkey; *key; ++key, ++p) {
			*p = *key;
			if (*p == '-') *p = '_';
		}
		*p = 0;
		key = newkey;
		for (q = allowed; *q; ++q) {
			if (!strcmp(key, *q)) break;
		}
		unless (*q) {
			L_errf(NULL, "illegal option '%s'",
			       Tcl_GetString(objv[i]));
			ret = TCL_ERROR;
		}
		if (val) {
			hash_put(L->options, key, val+1);
			*val = '=';
		} else {
			hash_put(L->options, key, "yes");
		}
	}
	return (ret);
}

/*
 * Parse an L script into an AST.  Parsing and compiling are broken into two
 * stages in order to support an interactive mode that parses many times
 * before finally compiling.
 */
private int
parse_script(char *str, Ast **ast_p, Tcl_Obj *nameObj)
{
	char	*prepend, *s;
	void	*lex_buffer;

	L_typeck_init();

	if (nameObj) {
		L->file = ckstrdup(Tcl_GetString(nameObj));
		L->dir  = L_dirname(L->file);
	} else {
		char *cwd = getcwd(NULL, 0);
		L->file = ckstrdup("<stdin>");
		L->dir  = ckstrdup(cwd);
		free(cwd);
	}

	/*
	 * Calculate the starting line # from the --line and --lineadj
	 * cmd-line options and inject a #line directive at the start
	 * of the source code.  This communicates the file-relative
	 * line # to code elsewhere that prints run-time error
	 * messages.
	 */
	if ((s = getenv("_L_LINE"))) {
		L->line = strtoul(s, NULL, 10);
	} else {
		if ((s = hash_get(L->options, "line"))) {
			L->line = atoi(s);
		} else {
			L->line = 1;
		}
		if ((s = hash_get(L->options, "lineadj"))) {
			L->line += atoi(s);
		}
	}
	prepend = cksprintf("#line %d\n", L->line);
	str = cksprintf("%s%s", prepend, str);

	L->token_off      = 0;
	L->prev_token_off = 0;
	L->prev_token_len = 0;
	L->errs		  = NULL;
	L_lex_start();
	lex_buffer	  = (void *)L__scan_bytes(str, strlen(str));

	L_parse();
	ASSERT(ast_p);
	*ast_p = L->ast;

	L__delete_buffer(lex_buffer);
	ckfree(str);
	ckfree(prepend);

	if (L->errs) {
		Tcl_SetObjResult(L->interp, L->errs);
		return (TCL_ERROR);
	}
	return (TCL_OK);
}

/* Compile an L AST into Tcl ByteCodes.  The envPtr may be NULL. */
private int
ast_compile(void *ast)
{
	int	ret = TCL_OK;
	TopLev	*toplev;
	static int ctr = 0;

	ASSERT(((Ast *)ast)->type == L_NODE_TOPLEVEL);

	L->toplev = cksprintf("%d%%l_toplevel", ctr++);

	init_predefined();  // set the L pre-defined identifiers

	/*
	 * Two frames get pushed, one for private globals that exist
	 * at file scope, and one for the top-level code.  See the
	 * comment in sym_store().
	 */
	frame_push(NULL, NULL, SCRIPT|SEARCH);
	frame_push(NULL, L->toplev, FUNC|TOPLEV|SKIP);

	/*
	 * Before compiling, enter prototypes for all functions into
	 * the global symbol table.
	 */
	for (toplev = (TopLev *)ast; toplev; toplev = toplev->next) {
		switch (toplev->kind) {
		    case L_TOPLEVEL_FUN:
			compile_fnDecl(toplev->u.fun, FN_PROTO_ONLY);
			break;
		    default:
			break;
		}
	}

	for (toplev = (TopLev *)ast; toplev; toplev = toplev->next) {
		switch (toplev->kind) {
		    case L_TOPLEVEL_CLASS:
			compile_clsDecl(toplev->u.class);
			break;
		    case L_TOPLEVEL_FUN:
			compile_fnDecl(toplev->u.fun, FN_PROTO_AND_BODY);
			break;
		    case L_TOPLEVEL_GLOBAL:
			compile_varDecls(toplev->u.global);
			break;
		    case L_TOPLEVEL_STMT:
			compile_stmts(toplev->u.stmt);
			break;
		    default:
			L_bomb("Unexpected toplevel stmt type %d", toplev->kind);
		}
	}

	/* If main() was defined, emit a %%call_main_if_defined call. */
	if (sym_lookup(mkId("main"), L_NOWARN)) {
		if (hash_get(L->options, "warn_undefined_fns")) {
			push_lit("%%check_L_fns");
			emit_invoke(1);
		}
		push_lit("%%call_main_if_defined");
		emit_invoke(1);
	}

	push_lit("");
	TclEmitOpcode(INST_DONE, L->frame->envPtr);
	frame_pop();
	frame_pop();

	if (L->errs) {
		Tcl_SetObjResult(L->interp, L->errs);
		return (TCL_ERROR);
	}

	if (hash_get(L->options, "norun") || (L->err && !getenv("_L_TEST"))) {
		/* Still check for undefined functions if requested. */
		if (hash_get(L->options, "warn_undefined_fns") &&
		    sym_lookup(mkId("main"), L_NOWARN)) {
			if (L->frame->envPtr) {
				push_lit("%%check_L_fns");
				emit_invoke(1);
			} else {
				Tcl_Eval(L->interp, "%%check_L_fns");
			}
		}
		return (TCL_OK);
	}

	/* Invoke the top-level code that was just compiled. */
	if (L->frame->envPtr) {
		push_lit("LtraceInit");
		emit_invoke(1);
		push_lit(L->toplev);
		emit_invoke(1);
	} else {
		if (Tcl_GetVar(L->interp, "::L_libl_done", 0)) {
			ret = Tcl_Eval(L->interp, "LtraceInit");
		}
		if (ret == TCL_OK) ret = Tcl_Eval(L->interp, L->toplev);
	}
	return (ret);
}

private void
init_predefined()
{
#define SET_INT(name, val) \
	Tcl_SetVar2Ex(L->interp, (name), NULL, Tcl_NewIntObj(val), \
		      TCL_GLOBAL_ONLY)

	/*
	 * These are flags used by compile_spawn_system() when
	 * compiling calls to libl.tcl's system_().  Pre-define them as L
	 * variables so that system_() in lib L can see their values.
	 */
	SET_INT("SYSTEM_ARGV__",	 SYSTEM_ARGV);
	SET_INT("SYSTEM_IN_STRING__",    SYSTEM_IN_STRING);
	SET_INT("SYSTEM_IN_ARRAY__",     SYSTEM_IN_ARRAY);
	SET_INT("SYSTEM_IN_FILENAME__",  SYSTEM_IN_FILENAME);
	SET_INT("SYSTEM_IN_HANDLE__",    SYSTEM_IN_HANDLE);
	SET_INT("SYSTEM_OUT_STRING__",   SYSTEM_OUT_STRING);
	SET_INT("SYSTEM_OUT_ARRAY__",    SYSTEM_OUT_ARRAY);
	SET_INT("SYSTEM_OUT_FILENAME__", SYSTEM_OUT_FILENAME);
	SET_INT("SYSTEM_OUT_HANDLE__",   SYSTEM_OUT_HANDLE);
	SET_INT("SYSTEM_ERR_STRING__",   SYSTEM_ERR_STRING);
	SET_INT("SYSTEM_ERR_ARRAY__",    SYSTEM_ERR_ARRAY);
	SET_INT("SYSTEM_ERR_FILENAME__", SYSTEM_ERR_FILENAME);
	SET_INT("SYSTEM_ERR_HANDLE__",   SYSTEM_ERR_HANDLE);
	SET_INT("SYSTEM_BACKGROUND__",   SYSTEM_BACKGROUND);

#undef SET_INT
}

private void
compile_clsDecl(ClsDecl *clsdecl)
{
	ASSERT(clsdecl->constructors);
	ASSERT(clsdecl->destructors);

	/*
	 * A class creates two scopes, one for the class symbols and
	 * the other for its top-level code (class variable
	 * initializers).  See the comments in sym_store().  The class
	 * symtab is persisted so it can be later retrieved from the
	 * class type to support obj->var or classname->var lookups.
	 */
	frame_push(NULL, NULL, CLS_OUTER|SEARCH|KEEPSYMS);
	clsdecl->symtab = L->frame->symtab;
	frame_push(NULL, NULL, CLS_TOPLEV|SKIP);
	L->frame->clsdecl = clsdecl;

	frame_resumePrologue();
	push_lit("::namespace");
	push_lit("eval");
	push_litf("::L::_class_%s", clsdecl->decl->id->str);
	push_lit("variable __num 0");
	emit_invoke(4);
	emit_pop();
	frame_resumeBody();

	compile_varDecls(clsdecl->clsvars);
	/* Process function decls first, then compile the bodies. */
	compile_fnDecls(clsdecl->fns, FN_PROTO_ONLY);
	compile_fnDecls(clsdecl->constructors, FN_PROTO_ONLY);
	compile_fnDecls(clsdecl->destructors, FN_PROTO_ONLY);
	compile_fnDecls(clsdecl->constructors, FN_PROTO_AND_BODY);
	compile_fnDecls(clsdecl->destructors, FN_PROTO_AND_BODY);
	compile_fnDecls(clsdecl->fns, FN_PROTO_AND_BODY);

	frame_pop();
	frame_pop();
}

/*
 * Take an expr list consisting of
 *
 * id		like the arg to "#pragma fntrace"
 * id=constant	like the arg to "#pragma fnhook=myhook"
 *
 * and add hash entries to the given hash.  The id's here aren't taken
 * as variables, but the name of the id itself is used, to avoid
 * making the programmer put everything inside quotes.  This is used
 * for #pragmas and function attributes.
 */
void
L_compile_attributes(Tcl_Obj *hash, Expr *expr, char *allowed[])
{
	Expr	*arg;
	char	*key, *val;
	char	**p;

	ASSERT(hash);
	for (arg = expr; arg; arg = arg->next) {
		if (arg->kind == L_EXPR_ID) {
			key = arg->str;
			val = "yes";
		} else if ((arg->kind == L_EXPR_BINOP) &&
			   (arg->op == L_OP_EQUALS)) {
			key = arg->a->str;
			val = arg->b->str;
			unless (isconst(arg->b) || (arg->b->kind == L_EXPR_ID)) {
				L_errf(arg,
				       "non-constant value for attribute %s",
				       key);
			}
		} else {
			L_errf(arg, "illegal attribute; not id or id=constant");
			continue;
		}
		for (p = allowed; *p; ++p) {
			if (!strcmp(key, *p)) break;
		}
		unless (*p) {
			L_errf(expr, "illegal attribute '%s'", key);
		} else {
			hash_put(hash, key, val);
		}
	}
}

private void
compile_fnDecls(FnDecl *fun, Decl_f flags)
{
	for (; fun; fun = fun->next) {
		compile_fnDecl(fun, flags);
	}
}

private void
compile_fnDecl(FnDecl *fun, Decl_f flags)
{
	int	i;
	VarDecl	*decl = fun->decl;
	char	*name = decl->id->str;
	char	*clsname = NULL;
	ClsDecl	*clsdecl = NULL;
	Sym	*self_sym = NULL;
	Sym	*sym;

	flags |= decl->flags;

	ASSERT(fun && decl);
	ASSERT(!(flags & SCOPE_LOCAL));
	ASSERT(flags & (SCOPE_CLASS | SCOPE_GLOBAL | SCOPE_SCRIPT));
	ASSERT(flags & (DECL_FN | DECL_CLASS_FN));
	// DECL_CLASS_FN ==> DECL_PUBLIC | DECL_PRIVATE
	ASSERT(!(flags & DECL_CLASS_FN) ||
	       (flags & (DECL_PUBLIC | DECL_PRIVATE)));
	ASSERT(flags & (FN_PROTO_ONLY | FN_PROTO_AND_BODY));

	/*
	 * Sort out the possible error cases:
	 *
	 * - main() declared with wrong types for formals
	 * - name illegal
	 * - name already declared as a variable
	 * - proto already declared and doesn't match this decl
	 * - this decl declares function body but body already declared
	 */
	if (!strcmp(name, "main")) L_typeck_main(decl);
	if (name[0] == '_') {
		L_errf(decl->id, "function names cannot begin with _");
	}
	if (!strcmp(name, "END")) {
		L_errf(decl->id, "cannot use END for function name");
	} else if (!strcmp(name, "undef")) {
		L_errf(decl->id, "cannot use undef for function name");
	}
	for (i = 0; i < sizeof(builtins)/sizeof(builtins[0]); ++i) {
		if (!strcmp(builtins[i].name, name)) {
			L_errf(decl->id,
			       "function '%s' conflicts with built-in",
			       name);
			return;
		}
	}
	sym = sym_lookup(decl->id, L_NOWARN|L_NOTUSED);
	if (sym) {
		unless (sym->kind & L_SYM_FN) {
			L_errf(fun, "%s already declared as a variable",name);
			return;
		} else if ((sym->kind & L_SYM_FNBODY) && fun->body) {
			L_errf(fun, "function %s already declared", name);
			return;
		} else unless (L_typeck_same(decl->type, sym->type)) {
			L_errf(fun, "does not match other declaration of %s",
			       name);
			return;
		}
	} else {
		sym = sym_store(decl);
		unless (sym) return;
	}

	/* Check arg and return types for legality. */
	L_typeck_declType(decl);

	if (!fun->body || (flags & FN_PROTO_ONLY)) return;

	/*
	 * Add this function's attributes to the hash of all declared
	 * functions in L->fn_decls which is put into the Tcl global
	 * variable L_fnsDeclared, for use by the function-tracing
	 * subsystem code in libl.tcl when tracing is enabled.
	 */
	L_compile_attributes(fun->attrs, decl->attrs, L_attrs_attribute);
	if (flags & FN_PROTO_AND_BODY) {
		Tcl_Obj	*key;
		Var	*arrayPtr, *varPtr;

		/*
		 * L->fn_decls can get out of date when the L code in
		 * lib L writes to L_fnsDeclared, so grab the latest.
		 */
		varPtr = TclLookupVar(L->interp,
				      "L_fnsDeclared",
				      NULL,
				      TCL_GLOBAL_ONLY,
				      NULL,
				      0,
				      0,
				      &arrayPtr);
		if (L->fn_decls != varPtr->value.objPtr) {
			L->fn_decls = varPtr->value.objPtr;
		}

		hash_put(fun->attrs, "name", name);
		hash_put(fun->attrs, "file", basenm(fun->node.loc.file));
		if (Tcl_IsShared(L->fn_decls)) {
			L->fn_decls = Tcl_DuplicateObj(L->fn_decls);
			Tcl_SetVar2Ex(L->interp, "L_fnsDeclared", NULL,
				      L->fn_decls, TCL_GLOBAL_ONLY);
		}
		key = Tcl_NewStringObj(sym->tclname, -1);
		Tcl_IncrRefCount(key);
		Tcl_DictObjPut(L->interp, L->fn_decls, key, fun->attrs);
		Tcl_DecrRefCount(key);
	}

	frame_push(fun, sym->tclname, FUNC|SEARCH);
	sym->kind |= L_SYM_FNBODY;
	L->frame->block = (Ast *)fun;

	compile_fnParms(decl);

	/* Gather class decl and name, for class member functions. */
	clsdecl = fun->decl->clsdecl;
	if (clsdecl) clsname = clsdecl->decl->id->str;

	/*
	 * For private class member fns and the constructor, declare
	 * the local variable "self".  For public member fns, lookup
	 * "self" which is required to be the first parameter (and is
	 * added by compile_fnParms if not present).
	 */
	if (isClsConstructor(decl) || isClsFnPrivate(decl)) {
		self_sym = sym_mk("self",
				  clsdecl->decl->type,
				  SCOPE_LOCAL | DECL_LOCAL_VAR);
		ASSERT(self_sym && self_sym->idx >= 0);
		self_sym->used_p = TRUE;
	} else if (isClsFnPublic(decl)) {
		self_sym = sym_lookup(mkId("self"), L_NOWARN);
		ASSERT(self_sym && self_sym->idx >= 0);
	}

	/*
	 * For a constructor, before compiling the user's
	 * constructor body, emit code to increment the class instance
	 * #, set "self" to the namespace name of the class instance,
	 * create the namespace, then compile the instance-variable
	 * initializers.  Basically this:
	 *
	 *     incrStkImm ::L::_class_<cls_name>::__num
	 *     set self ::L::_instance_<cls_name>${__num}
	 *     namespace eval $self {}
	 *     ...instance variable initializers...
	 *     ...user's constructor body...
	 */
	if (isClsConstructor(decl)) {
		frame_resumePrologue();
		ASSERT(clsdecl && clsname && self_sym);
		push_litf("::L::_class_%s::__num", clsname);
		TclEmitInstInt1(INST_INCR_STK_IMM, 1, L->frame->envPtr);
		emit_pop();
		push_lit("::namespace");
		push_lit("eval");
		push_litf("::L::_instance_%s", clsname);
		push_litf("::L::_class_%s::__num", clsname);
		TclEmitOpcode(INST_LOAD_STK, L->frame->envPtr);
		TclEmitInstInt1(INST_STR_CONCAT1, 2, L->frame->envPtr);
		emit_store_scalar(self_sym->idx);
		push_lit("");
		emit_invoke(4);
		emit_pop();
		frame_resumeBody();
		compile_varDecls(clsdecl->instvars);
	}

	/*
	 * For private member functions, upvar "self" to the "self" in
	 * the calling frame.  This works because only other class member
	 * functions can call private member functions, and they have "self".
	 */
	if (isClsFnPrivate(decl)) {
		frame_resumePrologue();
		push_lit("1");
		push_lit("self");
		TclEmitInstInt4(INST_UPVAR, self_sym->idx, L->frame->envPtr);
		emit_pop();
		frame_resumeBody();
	}

	L->enclosing_func = fun;
	L->enclosing_func_frame = L->frame;
	compile_block(fun->body);
	L->enclosing_func = NULL;
	L->enclosing_func_frame = NULL;

	/*
	 * Emit a "fall off the end" implicit return for void
	 * functions.  Class constructors return the value of "self".
	 * Non-void functions throw an exception if you fall
	 * off the end.
	 */
	if (isClsConstructor(decl)) {
		emit_load_scalar(self_sym->idx);
	} else if (isvoidtype(decl->type->base_type)) {
		push_lit("");
	} else {
		push_lit("::throw");
		push_lit("{FUNCTION NO-RETURN-VALUE "
			 "{no value returned from function}}");
		push_lit("no value returned from function");
		emit_invoke(3);
	}

	/*
	 * Fix-up the return jmps so that all return stmts jump to here.
	 * The return value will already be on the run-time stack.
	 */
	fixup_jmps(&L->frame->ret_jmps);

	/*
	 * For class destructor, delete the instance namespace.
	 */
	if (isClsDestructor(decl)) {
		ASSERT(self_sym);
		push_lit("::namespace");
		push_lit("delete");
		emit_load_scalar(self_sym->idx);
		emit_invoke(3);
		emit_pop();
	}

	TclEmitOpcode(INST_DONE, L->frame->envPtr);

	frame_pop();
}

/*
 * Push a semantic-stack frame.  If flags & FUNC, start a new proc
 * too.  To support the delayed generation of proc prologue code, we
 * allocate two CompileEnv's, one for the proc body and one for its
 * prologue.  You switch between the two with frame_resumePrologue()
 * and frame_resumeBody().  A jump is emitted at the head of the proc
 * that jumps to the end, and when the proc is done being compiled,
 * the prologue code is emitted at the end along with a jump back.
 * This provides a way to lazily output proc initialization code, such
 * as the upvars for accessing globals and class variables.
 */
private void
frame_push(void *node, char *name, Frame_f flags)
{
	Frame	*frame;
	Proc	*proc;
	CompileEnv *bodyEnvPtr, *prologueEnvPtr;

	frame = (Frame *)ckalloc(sizeof(Frame));
	memset(frame, 0, sizeof(*frame));
	frame->flags  = flags;
	frame->symtab = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(frame->symtab, TCL_STRING_KEYS);
	frame->labeltab = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(frame->labeltab, TCL_STRING_KEYS);
	frame->prevFrame = L->frame;
	L->frame = frame;

	unless (frame->flags & FUNC) {
		frame->block = node;
		if (frame->prevFrame) {
			frame->envPtr = frame->prevFrame->envPtr;
			frame->bodyEnvPtr = frame->prevFrame->bodyEnvPtr;
			frame->prologueEnvPtr = frame->prevFrame->prologueEnvPtr;
		}
		return;
	}

	bodyEnvPtr     = (CompileEnv *)ckalloc(sizeof(CompileEnv));
	prologueEnvPtr = (CompileEnv *)ckalloc(sizeof(CompileEnv));
	frame->bodyEnvPtr = bodyEnvPtr;
	frame->prologueEnvPtr = prologueEnvPtr;
	frame->envPtr = bodyEnvPtr;

	proc = (Proc *)ckalloc(sizeof(Proc));
	proc->iPtr		= (struct Interp *)L->interp;
	proc->refCount		= 1;
	proc->numArgs		= 0;
	proc->numCompiledLocals = 0;
	proc->firstLocalPtr     = NULL;
	proc->lastLocalPtr      = NULL;
	proc->bodyPtr		= Tcl_NewObj();
	Tcl_IncrRefCount(proc->bodyPtr);
	TclInitCompileEnv(L->interp, bodyEnvPtr, TclGetString(L->script),
			  L->script_len, NULL, 0);
	bodyEnvPtr->procPtr = proc;

	TclInitCompileEnv(L->interp, prologueEnvPtr, NULL, 0, NULL, 0);

	frame->proc = proc;
	frame->name = name;

	/*
	 * Emit a jump to what will eventually be the prologue code
	 * (output by frame_pop()).
	 */
	frame->end_jmp  = emit_jmp_fwd(INST_JUMP4, NULL);
	frame->proc_top = currOffset(frame->envPtr);
}

private void
frame_resumePrologue()
{
	L->frame->envPtr = L->frame->prologueEnvPtr;
}

private void
frame_resumeBody()
{
	L->frame->envPtr = L->frame->bodyEnvPtr;
}

private void
frame_pop()
{
	int	off;
	Frame	*frame = L->frame;
	Proc	*proc  = frame->proc;
	Sym	*sym;
	Label	*label;
	ByteCode *codePtr;
	Tcl_HashEntry *hPtr;
	Tcl_HashSearch hSearch;

	/*
	 * Emit proc prologue code and the jump back to the head of
	 * the proc.  Splice in any code in the frame->prologueEnvPtr
	 * CompileEnv.  This is dependent on CompileEnv details.
	 */
	if (frame->flags & FUNC) {
		CompileEnv	*body = frame->bodyEnvPtr;
		CompileEnv	*prologue = frame->prologueEnvPtr;
		int		len = prologue->codeNext - prologue->codeStart;

		ASSERT(frame->envPtr == frame->bodyEnvPtr);

		fixup_jmps(&frame->end_jmp);
		while ((body->codeNext + len) >= body->codeEnd) {
			TclExpandCodeArray(body);
		}
		memcpy(body->codeNext, prologue->codeStart, len);
		body->codeNext += len;
		if (prologue->maxStackDepth > body->maxStackDepth) {
			body->maxStackDepth = prologue->maxStackDepth;
		}
		off = currOffset(frame->envPtr);
		TclEmitInstInt4(INST_JUMP4, frame->proc_top-off, frame->envPtr);
	}

	/*
	 * Check for unused local symbols, and free the frame's symbol table.
	 */
	for (hPtr = Tcl_FirstHashEntry(frame->symtab, &hSearch);
	     hPtr != NULL;
	     hPtr = Tcl_NextHashEntry(&hSearch)) {
		sym = (Sym *)Tcl_GetHashValue(hPtr);
		unless (sym->used_p || !(sym->kind & L_SYM_LVAR) ||
			(sym->decl->flags & DECL_ARGUSED)) {
			L_warnf(sym->decl, "%s unused", sym->name);
		}
		unless (frame->flags & KEEPSYMS) {
			ckfree(sym->name);
			ckfree(sym->tclname);
			ckfree((char *)sym);
		}
	}
	unless (frame->flags & KEEPSYMS) {
		Tcl_DeleteHashTable(frame->symtab);
		ckfree((char *)frame->symtab);
	}

	/*
	 * Check for unresolved labels, and free the frame's label table.
	 */
	for (hPtr = Tcl_FirstHashEntry(frame->labeltab, &hSearch);
	     hPtr != NULL;
	     hPtr = Tcl_NextHashEntry(&hSearch)) {
		label = (Label *)Tcl_GetHashValue(hPtr);
		unless (label->offset >= 0) {
			L_err("label %s referenced but not defined",
			      label->name);
		}
		ckfree((char *)label);
	}
	Tcl_DeleteHashTable(frame->labeltab);
	ckfree((char *)frame->labeltab);

	/*
	 * Create the Tcl command and free the old frame.
	 */
	if (frame->flags & FUNC) {
		TclInitByteCodeObj(proc->bodyPtr, frame->envPtr);
		proc->cmdPtr = (Command *)Tcl_CreateObjCommand(L->interp,
							frame->name,
							TclObjInterpProc,
							(ClientData)proc,
							TclProcDeleteProc);
		// Don't recompile on compileEpoch changes.
		codePtr = (ByteCode *)proc->bodyPtr->internalRep.twoPtrValue.ptr1;
		codePtr->flags |= TCL_BYTECODE_PRECOMPILED;
		TclFreeCompileEnv(frame->bodyEnvPtr);
		TclFreeCompileEnv(frame->prologueEnvPtr);
		ckfree((char *)frame->bodyEnvPtr);
		ckfree((char *)frame->prologueEnvPtr);
	}

	L->frame = frame->prevFrame;
	tmp_freeAll(frame->tmps);
	ckfree((char *)frame);
}

private Frame *
frame_find(Frame_f flags)
{
	Frame	*f = L->frame;

	ASSERT(f);
	while (f && !(f->flags & flags)) f = f->prevFrame;
	return (f);
}

private char *
frame_name()
{
	if (L->enclosing_func) {
		return(L->enclosing_func->decl->id->str);
	} else {
		return(L->toplev);
	}
}

private void
compile_varInitializer(VarDecl *decl)
{
	int	start_off = currOffset(L->frame->envPtr);

	unless (decl->initializer) {
		decl->initializer = ast_mkBinOp(L_OP_EQUALS,
						decl->id,
						mkId("undef"),
						decl->node.loc,
						decl->node.loc);
	}
	compile_expr(decl->initializer, L_DISCARD);
	track_cmd(start_off, decl);
}

private void
compile_varDecl(VarDecl *decl)
{
	char	*name;
	Sym	*sym;

	/*
	 * Process any declaration only once, but generate code for
	 * its initializers each time through here.  This is for class
	 * constructors where the class instance variables get
	 * compiled once for each constructor.
	 */
	if (decl->flags & DECL_DONE) {
		compile_varInitializer(decl);
		return;
	}
	decl->flags |= DECL_DONE;

	ASSERT(decl->id && decl->type);

	name = decl->id->str;

	unless (L_typeck_declType(decl)) return;

	if (decl->flags & DECL_LOCAL_VAR) {
		if (name[0] == '_') {
			L_errf(decl,
			       "local variable names cannot begin with _");
		}
		if (decl->flags & (DECL_PRIVATE | DECL_PUBLIC)) {
			L_errf(decl,
			       "public/private qualifiers illegal for locals");
			decl->flags &= ~(DECL_PRIVATE | DECL_PUBLIC);
		}
	}
	if (!strcmp(name, "END")) {
		L_errf(decl, "cannot use END for variable name");
		return;
	} else if (!strcmp(name, "undef")) {
		L_errf(decl, "cannot use undef for variable name");
		return;
	}
	if ((decl->type->kind == L_CLASS) &&
	    !strcmp(name, decl->type->u.class.clsdecl->decl->id->str)) {
		L_errf(decl, "cannot declare object with same name as class");
	}

	sym = sym_store(decl);
	unless (sym) return;  // bail if multiply declared

	if (decl->flags & DECL_EXTERN) {
		if (decl->initializer) {
			L_errf(decl, "extern initializers illegal");
		}
		unless (L->frame->flags & TOPLEV) {
			L_errf(decl, "externs legal only at global scope");
		}
		sym->used_p = TRUE;  // to suppress extraneous warning
		return;
	}

	compile_varInitializer(decl);

	/* Mark var as unused even though it was just initialized. */
	sym->used_p = FALSE;
}

private void
compile_varDecls(VarDecl *decls)
{
	for (; decls; decls = decls->next) {
		compile_varDecl(decls);
	}
}

private void
compile_stmt(Stmt *stmt)
{
	int	start_off = currOffset(L->frame->envPtr);

	unless (stmt) return;
	switch (stmt->kind) {
	    case L_STMT_BLOCK:
		frame_push(stmt, NULL, SEARCH);
		compile_block(stmt->u.block);
		frame_pop();
		break;
	    case L_STMT_EXPR:
		compile_exprs(stmt->u.expr, L_DISCARD);
		break;
	    case L_STMT_COND:
		compile_ifUnless(stmt->u.cond);
		break;
	    case L_STMT_LOOP:
		compile_loop(stmt->u.loop);
		break;
	    case L_STMT_SWITCH:
		compile_switch(stmt->u.swich);
		break;
	    case L_STMT_FOREACH:
		compile_foreach(stmt->u.foreach);
		break;
	    case L_STMT_RETURN:
		compile_return(stmt);
		break;
	    case L_STMT_BREAK:
		compile_break(stmt);
		break;
	    case L_STMT_CONTINUE:
		compile_continue(stmt);
		break;
	    case L_STMT_LABEL:
		compile_label(stmt);
		break;
	    case L_STMT_GOTO:
		compile_goto(stmt);
		break;
	    case L_STMT_TRY:
		compile_trycatch(stmt);
		break;
	    default:
		L_bomb("Malformed AST in compile_stmt");
	}
	switch (stmt->kind) {
	    case L_STMT_BLOCK:
	    case L_STMT_COND:
	    case L_STMT_EXPR:
	    case L_STMT_TRY:
		break;
	    default:
		track_cmd(start_off, stmt);
		break;
	}
}

private void
compile_stmts(Stmt *stmts)
{
	for (; stmts; stmts = stmts->next) {
		compile_stmt(stmts);
	}
}

private void
compile_trycatch(Stmt *stmt)
{
	int	range;
	int	msg_idx = -1;
	Jmp	*jmp;
	Try	*try = stmt->u.try;
	Expr	*msg = try->msg;

	if (msg) {
		unless (msg->op == L_OP_ADDROF) {
			L_errf(msg, "expected catch(&variable)");
			return;
		}
		compile_expr(msg, L_DISCARD);
		if (msg->a->sym) {
			msg_idx = msg->a->sym->idx;
		} else {
			L_errf(msg->a, "illegal operand to &");
		}
	}

	range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, L->frame->envPtr);
	TclEmitInstInt4(INST_BEGIN_CATCH4, range, L->frame->envPtr);

	/*
	 * Emit separate INST_END_CATCH's for the non-error and error
	 * paths so that a return can be done inside of a catch()
	 * clause -- the "try" is done when the body finishes without
	 * error or by the time the catch() is entered.
	 */

	/* body */
	ExceptionRangeStarts(L->frame->envPtr, range);
	compile_stmts(try->try);
	ExceptionRangeEnds(L->frame->envPtr, range);
	TclEmitOpcode(INST_END_CATCH, L->frame->envPtr);
	jmp = emit_jmp_fwd(INST_JUMP4, 0);

	/* error case */
	ExceptionRangeTarget(L->frame->envPtr, range, catchOffset);
	if (msg_idx != -1) {
		TclEmitOpcode(INST_PUSH_RESULT, L->frame->envPtr);
		TclEmitInstInt4(INST_STORE_SCALAR4, msg_idx, L->frame->envPtr);
		TclEmitOpcode(INST_POP, L->frame->envPtr);
	}
	TclEmitOpcode(INST_END_CATCH, L->frame->envPtr);
	compile_stmts(try->catch);

	/* out */
	fixup_jmps(&jmp);
}

private void
compile_block(Block *block)
{
	compile_varDecls(block->decls);
	compile_stmts(block->body);
}

private void
compile_return(Stmt *stmt)
{
	VarDecl	*decl;
	Type	*ret_type;

	/* Handle return from the top level. */
	unless (L->enclosing_func) {
		if (stmt->u.expr) {
			compile_expr(stmt->u.expr, L_PUSH_VAL);
		} else {
			push_lit("");
		}
		TclEmitOpcode(INST_DONE, L->frame->envPtr);
		return;
	}

	decl     = L->enclosing_func->decl;
	ret_type = decl->type->base_type;

	if (isvoidtype(ret_type) && (stmt->u.expr)) {
		L_errf(stmt, "void function cannot return value");
		compile_expr(stmt->u.expr, L_DISCARD);
	} else if (stmt->u.expr) {
		compile_expr(stmt->u.expr, L_PUSH_VAL);  // return value
		unless (L_typeck_compat(ret_type, stmt->u.expr->type)) {
			L_errf(stmt, "incompatible return type");
		}
	} else unless (isvoidtype(ret_type)) {
		L_errf(stmt, "must specify return value");
	} else {
		push_lit("");  // no return value -- push a ""
	}

	/* Jmp to the function end where any necessary clean-up code is. */
	ASSERT(L->enclosing_func_frame);
	L->enclosing_func_frame->ret_jmps =
		emit_jmp_fwd(INST_JUMP4, L->enclosing_func_frame->ret_jmps);
}

private void
proc_mkArg(Proc *proc, VarDecl *decl)
{
	int	argnum;
	char	*name = decl->id->str;
	CompiledLocal *local;

	argnum = proc->numArgs++;
	++proc->numCompiledLocals;
	local = (CompiledLocal *)ckalloc(sizeof(CompiledLocal) -
					 sizeof(local->name) +
					 strlen(name) + 1);
	if (proc->firstLocalPtr == NULL) {
		proc->firstLocalPtr = local;
		proc->lastLocalPtr  = local;
	} else {
		proc->lastLocalPtr->nextPtr = local;
		proc->lastLocalPtr = local;
	}
	local->nextPtr     = NULL;
	local->resolveInfo = NULL;
	local->defValuePtr = NULL;
	local->frameIndex  = argnum;
	local->nameLength  = strlen(name);
	strcpy(local->name, name);

	local->flags = VAR_ARGUMENT;
	if (decl->flags & DECL_REST_ARG) local->flags |= VAR_IS_ARGS;
	if (decl->flags & DECL_OPTIONAL) {
		if (isnameoftype(decl->type)) {
			local->defValuePtr =
				Tcl_NewStringObj("::L_undef_ref_parm_", -1);
			local->defValuePtr->undef = 1;
		} else {
			local->defValuePtr = *L_undefObjPtrPtr();
		}
		Tcl_IncrRefCount(local->defValuePtr);
	}
}

/*
 * Determine whether the parameter-passing mode for a formal parameter
 * declaration is call-by-reference.  Return NULL or the base type of
 * the parameter (without the name-of).  You get call-by-reference if
 * the parameter was declared with & and is not a function pointer.
 */
private Type *
iscallbyname(VarDecl *formal)
{
	unless (formal) return (NULL);
	if (formal->flags & DECL_REF) {
		if (isfntype(formal->type->base_type)) {
			return (NULL);
		} else {
			return (formal->type->base_type);
		}
	}
	return (NULL);
}

private int
compile_fnParms(VarDecl *decl)
{
	int	n;
	int	name_parms = 0;
	char	*name;
	Proc	*proc = L->frame->envPtr->procPtr;
	Expr	*varId;
	VarDecl	*p, *varDecl;
	Sym	*parmSym, *varSym;
	Type	*type;
	VarDecl	*param = decl->type->u.func.formals;

	proc->numArgs = 0;
	proc->numCompiledLocals = 0;

	/*
	 * Public class member fns (except constructor) must have "self"
	 * as the first arg and it must be of the class type.
	 */
	if (isClsFnPublic(decl) && !isClsConstructor(decl)) {
		Type	*clstype = decl->clsdecl->decl->type;
		Expr	*self_id;
		VarDecl	*self_decl;
		unless (param && param->id && isid(param->id, "self")) {
			L_errf(decl->id, "class public member function lacks "
			       "'self' as first arg");
			/* Add it so we can keep compiling. */
			self_id   = mkId("self");
			self_decl = ast_mkVarDecl(clstype, self_id,
						  decl->node.loc,
						  decl->node.loc);
			self_decl->flags = SCOPE_LOCAL | DECL_LOCAL_VAR;
			self_decl->next = param;
			param = self_decl;
		} else unless (L_typeck_same(param->type, clstype)) {
			L_errf(param, "'self' parameter must be of class type");
		}
	}

	/*
	 * To handle call-by-name formals, make two passes through the
	 * formals list.  In the first pass, mangle any formal name to
	 * "&name".  In the second pass, for formals only, create a
	 * local "name" as an upvar to the variable one frame up whose
	 * name is passed in the arg.  Note that the formal will have
	 * type "name-of <t>" and the local gets type <t>.  This is
	 * needed since Tcl requires the locals to follow the args.
	 */
	for (p = param, n = 0; p; p = p->next, n++) {
		unless (p->id) {
			L_errf(p, "formal parameter #%d lacks a name", n+1);
			name = cksprintf("unnamed-arg-%d", n+1);
			p->id = mkId(name);
			ckfree(name);
		}
		if (isClsConstructor(decl) && isid(p->id, "self")) {
			L_errf(p,
			       "'self' parameter illegal in class constructor");
			continue;
		}
		if (isClsFnPrivate(decl) && isid(p->id, "self")) {
			L_errf(p,
			       "'self' parameter illegal in private function");
			continue;
		}
		if ((p->flags & DECL_REST_ARG) && (p->next)) {
			L_errf(p, "Rest parameter must be last");
		}
		if ((p->flags & DECL_OPTIONAL) && (p->next)) {
			L_errf(p, "_optional parameter must be last");
		}
		if (typeis(p->type, "FMT") &&
		    (!p->next || !(p->next->flags & DECL_REST_ARG))) {
			L_errf(p, "rest argument must follow FMT");
		}
		if (iscallbyname(p)) {
			name = cksprintf("&%s", p->id->str);
			ckfree(p->id->str);
			p->id->str = name;
			++name_parms;
		}
		proc_mkArg(proc, p);
		parmSym = sym_store(p);
		unless (parmSym) continue;  // multiple declaration
		parmSym->idx = n;
		/* Suppress unused warning for obj arg to class member fns. */
		if ((p == param) &&
		    isClsFnPublic(decl) && !isClsConstructor(decl)) {
			parmSym->used_p = TRUE;
		}
	}
	/* For call by name, push a 1 the first time (arg to INST_UPVAR). */
	if (name_parms) push_lit("1");
	/*
	 * For each call-by-reference formal, we have
	 * "&var" - a fn parm that gets the name of the caller's actual parm
	 * "var" - a local upvar'd to this name, becomes alias for the actual
	 * The first was created above.  Create the second one now.
	 */
	for (p = param; p; p = p->next) {
		unless (type = iscallbyname(p)) continue;

		/* Lookup "&var". */
		parmSym = sym_lookup(p->id, L_NOWARN);
		ASSERT(parmSym && (p->id->str[0] == '&'));

		/* Create "var". */
		varId   = ast_mkId(p->id->str + 1,  // point past the &
				   p->id->node.loc,
				   p->id->node.loc);
		varDecl = ast_mkVarDecl(type, varId, p->node.loc, p->node.loc);
		varDecl->flags = SCOPE_LOCAL | DECL_LOCAL_VAR | p->flags;
		varDecl->node.loc.line = p->node.loc.line;
		unless (varSym = sym_store(varDecl)) continue; // multiple decl
		varSym->decl->refsym = parmSym;
		emit_load_scalar(parmSym->idx);
		TclEmitInstInt4(INST_UPVAR, varSym->idx, L->frame->envPtr);
	}
	/* Pop the 1 pushed for INST_UPVAR. */
	if (name_parms) emit_pop();
	return (n);
}

private int
compile_rename(Expr *expr)
{
	int	n;

	push_lit("frename_");
	n = compile_exprs(expr->b, L_PUSH_VAL);
	unless (n == 2) {
		L_errf(expr, "incorrect # args for rename");
	}
	emit_invoke(3);
	expr->type = L_int;
	return (1);  // stack effect
}

private int
compile_split(Expr *expr)
{
	int	n;
	Expr	*str = NULL, *lim = NULL, *sep = NULL;
	Expr_f	flags = 0;

	expr->type = L_poly;  // for err return path
	n = compile_exprs(expr->b, L_PUSH_VAL);
	ASSERT(n > 0);  // grammar ensures this
	if (n > 3) {
		L_errf(expr, "too many args to split");
		return (0);
	}
	switch (n) {
	    case 1:	// split(<str>)
		str = expr->b;
		break;
	    case 2:	// split(/re/, <str>)
		sep = expr->b;
		str = sep->next;
		break;
	    case 3:	// split(/re/, <str>, <lim>)
		sep = expr->b;
		str = sep->next;
		lim = str->next;
		break;
	}
	unless (istype(str, L_STRING|L_WIDGET|L_POLY)) {
		L_errf(str, "expression to split must be string");
	}
	if (sep) {
		unless (isregexp(sep)) {
			L_errf(sep, "split delimiter must be a "
			       "regular expression");
		}
		if (sep->flags & ~(L_EXPR_RE_T | L_EXPR_RE_I)) {
			L_errf(sep, "illegal regular expression modifier");
		}
		flags |= L_SPLIT_RE | sep->flags;
	}
	if (lim) {
		flags |= L_SPLIT_LIM;
		unless (isint(lim)) {
			L_errf(expr, "third arg to split must be integer");
			return (0);
		}
	}
	TclEmitInstInt4(INST_L_SPLIT, flags, L->frame->envPtr);
	TclAdjustStackDepth(n-1, L->frame->envPtr);
	expr->type = type_mkArray(0, L_string);
	return (1);  // stack effect
}

private int
compile_push(Expr *expr)
{
	int	flags = 0, i, idx;
	Expr	*arg, *array;
	Type	*base_type;
	Tmp	*tmp;

	expr->type = L_void;
	unless (expr->b && expr->b->next) {
		L_errf(expr, "too few arguments to push");
		return (0);
	}
	unless (isaddrof(expr->b)) {
		L_errf(expr, "first arg to push not an array reference (&)");
		return (0);
	}
	ASSERT(expr->b->a);
	array = expr->b->a;
	arg   = expr->b->next;
	compile_expr(array, L_PUSH_PTR | L_LVALUE);
	unless (isarray(array) || ispoly(array)) {
		L_errf(expr,
		       "first arg to push not an array reference (&)");
		return (0);
	}
	unless (array->sym) {
		L_errf(expr, "invalid l-value in push");
		return (0);
	}
	idx = array->sym->idx;  // local slot # for array
	if (isarray(array)) {
		base_type = array->type->base_type;
	} else {
		base_type = L_poly;
	}
	if (arg->next) {
		/* Build up a list of the args to push. */
		tmp = tmp_get(TMP_REUSE);
		push_lit("");
		emit_store_scalar(tmp->idx);
		emit_pop();
		for (i = 2; arg; arg = arg->next, ++i) {
			compile_expr(arg, L_PUSH_VAL);
			/* We allow base_type or an array of base_type. */
			if (L_typeck_compat(base_type, arg->type)) {
				flags = L_INSERT_ELT;
			} else if (L_typeck_compat(array->type, arg->type)) {
				flags = L_INSERT_LIST;
			} else {
				L_errf(expr, "arg #%d to push has type "
				       "incompatible with array", i);
			}
			push_lit("-1");  // -1 means append
			TclEmitInstInt4(INST_L_LIST_INSERT, tmp->idx,
					L->frame->envPtr);
			TclEmitInt4(flags, L->frame->envPtr);
		}
		emit_load_scalar(tmp->idx);
		tmp_free(tmp);
		flags = L_INSERT_LIST;
	} else {
		compile_expr(arg, L_PUSH_VAL);
		/* We allow base_type or an array of base_type. */
		if (L_typeck_compat(base_type, arg->type)) {
			flags = L_INSERT_ELT;
		} else if (L_typeck_compat(array->type, arg->type)) {
			flags = L_INSERT_LIST;
		} else {
			L_errf(expr, "arg #2 to push has type "
			       "incompatible with array");
		}
	}
	if (array->flags & L_EXPR_DEEP) {
		// deep-ptr rval
		TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr);
		// rval deep-ptr
		push_lit("-1");  // -1 means append
		TclEmitInstInt4(INST_L_DEEP_WRITE, idx,
				L->frame->envPtr);
		TclEmitInt4(flags | L_DISCARD, L->frame->envPtr);
	} else {
		push_lit("-1");  // -1 means append
		TclEmitInstInt4(INST_L_LIST_INSERT, idx,
				L->frame->envPtr);
		TclEmitInt4(flags, L->frame->envPtr);
	}
	return (0);  // stack effect
}

private int
compile_pop_shift(Expr *expr)
{
	int	idx;
	Expr	*arg = NULL;
	char	*opNm = expr->a->str;
	Expr	*toDelete;
	YYLTYPE	loc;

	expr->type = L_poly;
	unless (expr->b && !expr->b->next) {
		L_errf(expr, "incorrect # arguments to %s", opNm);
		return (0);
	}
	unless (isaddrof(expr->b)) {
		L_errf(expr, "arg to %s not an array reference (&)", opNm);
		return (0);
	}
	/*
	 * For pop, change arg from &arr to &arr[END] and then delete
	 * that element.  For shift, use &arr[0].
	 */
	ASSERT(expr->b->a);
	loc = expr->b->a->node.loc;
	if (!strcmp(opNm, "pop")) {
		toDelete = mkId("END");
	} else {
		toDelete = ast_mkConst(L_int, ckstrdup("0"), loc, loc);
	}
	arg = ast_mkBinOp(L_OP_ARRAY_INDEX,
			  expr->b->a,
			  toDelete,
			  loc,
			  loc);
	expr->b->a = arg;
	/* L_NEG_OK here permits indexing element -1 (array already empty). */
	compile_expr(arg, L_PUSH_PTR | L_DELETE | L_NEG_OK | L_LVALUE);
	unless (isarray(arg->a) || ispoly(arg->a)) {
		L_errf(expr, "arg to %s not an array reference (&)", opNm);
		return (0);
	}
	unless (arg->sym) {
		L_errf(expr, "invalid l-value in %s", opNm);
		return (0);
	}
	idx = arg->sym->idx;  // local slot # for array
	TclEmitInstInt4(INST_L_DEEP_WRITE, idx, L->frame->envPtr);
	TclEmitInt4(L_DELETE | L_PUSH_OLD, L->frame->envPtr);
	TclAdjustStackDepth(1, L->frame->envPtr);
	expr->type = arg->type;
	return (1);  // stack effect
}

private int
compile_insert_unshift(Expr *expr)
{
	int	flags, i, idx;
	Expr	*arg, *array, *index;
	Type	*base_type;
	Tmp	*argTmp = NULL, *idxTmp = NULL;
	char	*opNm = expr->a->str;

	/*
	 * Make unshift(arg1, arg2, ...) look like insert(arg1, "0", arg2, ...)
	 */
	if (!strcmp(opNm, "unshift")) {
		if (expr->b) {
			arg = ast_mkConst(L_int, ckstrdup("0"), expr->node.loc,
					  expr->node.loc);
			arg->next = expr->b->next;
			expr->b->next = arg;
		}
		i = 2;  // where data args start
	} else {
		i = 3;  // where data args start
	}

	expr->type = L_void;
	unless (expr->b && expr->b->next && expr->b->next->next) {
		L_errf(expr, "too few arguments to %s", opNm);
		return (0);
	}
	ASSERT(expr->b->a);
	array = expr->b->a;
	index = expr->b->next;
	arg   = expr->b->next->next;
	unless (isaddrof(expr->b)) {
		L_errf(expr, "first arg to %s not an array reference (&)", opNm);
		return (0);
	}
	compile_expr(array, L_PUSH_PTR | L_LVALUE);
	unless (isarray(array) || ispoly(array)) {
		L_errf(expr,
		       "first arg to %s not an array reference (&)", opNm);
		return (0);
	}
	unless (array->sym) {
		L_errf(expr, "invalid l-value in %s", opNm);
		return (0);
	}
	idx = array->sym->idx;  // local slot # for array
	if (isarray(array)) {
		base_type = array->type->base_type;
	} else {
		base_type = L_poly;
	}

	/*
	 * If >1 arg, concat them all into a temp and insert that.  We
	 * can't just insert them one by one like we do in
	 * compile_push(), since that would insert them backwards.
	 * We could reverse the arg list, but building the temp is
	 * about as fast as re-indexing into the array for each element.
	 */
	if (arg->next) {
		idxTmp = tmp_get(TMP_REUSE);
		compile_expr(index, L_PUSH_VAL);
		emit_store_scalar(idxTmp->idx);
		emit_pop();
		unless (isint(index)) {
			L_errf(expr, "second arg to %s not an int", opNm);
			return (0);
		}
		argTmp = tmp_get(TMP_REUSE);
		push_lit("");
		emit_store_scalar(argTmp->idx);
		emit_pop();
		for (; arg; arg = arg->next, ++i) {
			compile_expr(arg, L_PUSH_VAL);
			/* For an arg, allow base_type or array of base_type. */
			unless (L_typeck_compat(base_type, arg->type) ||
				L_typeck_compat(array->type, arg->type)) {
				L_errf(expr, "arg #%d to %s has type "
				       "incompatible with array", i, opNm);
			}
			if (isarray(arg) || islist(arg)) {
				flags = L_INSERT_LIST;
			} else {
				flags = L_INSERT_ELT;
			}
			push_lit("-1");  // -1 means append
			TclEmitInstInt4(INST_L_LIST_INSERT, argTmp->idx,
					L->frame->envPtr);
			TclEmitInt4(flags, L->frame->envPtr);
		}
		if (array->flags & L_EXPR_DEEP) {
			emit_load_scalar(argTmp->idx);
			TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr);
			emit_load_scalar(idxTmp->idx);
			TclEmitInstInt4(INST_L_DEEP_WRITE, idx,
					L->frame->envPtr);
			TclEmitInt4(L_INSERT_LIST | L_DISCARD,
				    L->frame->envPtr);
		} else {
			emit_load_scalar(argTmp->idx);
			emit_load_scalar(idxTmp->idx);
			TclEmitInstInt4(INST_L_LIST_INSERT, idx,
					L->frame->envPtr);
			TclEmitInt4(L_INSERT_LIST, L->frame->envPtr);
		}
	} else {
		compile_expr(arg, L_PUSH_VAL);
		/* For the arg, we allow base_type or an array of base_type. */
		unless (L_typeck_compat(base_type, arg->type) ||
			L_typeck_compat(array->type, arg->type)) {
			L_errf(expr, "arg #%d to %s has type incompatible "
			       "with array", i, opNm);
		}
		if (isarray(arg) || islist(arg)) {
			flags = L_INSERT_LIST;
		} else {
			flags = L_INSERT_ELT;
		}
		if (array->flags & L_EXPR_DEEP) {
			TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr);
		}
		compile_expr(index, L_PUSH_VAL);
		unless (isint(index)) {
			L_errf(expr, "second arg to %s not an int", opNm);
			return (0);
		}
		if (array->flags & L_EXPR_DEEP) {
			TclEmitInstInt4(INST_L_DEEP_WRITE, idx,
					L->frame->envPtr);
			TclEmitInt4(flags | L_DISCARD, L->frame->envPtr);
		} else {
			TclEmitInstInt4(INST_L_LIST_INSERT, idx,
					L->frame->envPtr);
			TclEmitInt4(flags, L->frame->envPtr);
		}
	}
	tmp_free(idxTmp);
	tmp_free(argTmp);
	return (0);  // stack effect
}

private void
compile_eq_stack(Expr *expr, Type *type)
{
	int	i, top_off;
	Tmp	*itmp, *ltmp, *rtmp;
	Jmp	*out = NULL;
	Jmp	*out_false = NULL, *out_false2 = NULL, *out_true = NULL;
	VarDecl	*v;

	unless (type->kind & (L_ARRAY|L_STRUCT|L_HASH)) {
		/* Scalar -- just need a single bytecode. */
		emit_instrForLOp(expr, type);
		return;
	}

	/* Put lhs and rhs into temps. */
	ltmp = tmp_get(TMP_REUSE);
	rtmp = tmp_get(TMP_REUSE);
	emit_store_scalar(rtmp->idx);
	emit_pop();
	emit_store_scalar(ltmp->idx);
	emit_pop();

	switch (type->kind) {
	    case L_ARRAY:
		itmp = tmp_get(TMP_UNSET);
		/*
		 *     if (length(lhs) != length(rhs)) goto out_false
		 *     itmp = length(rhs)
		 * top_off:
		 *     if (itmp == 0) goto out_true
		 *     --itmp
		 *     if (lhs[itmp] != rhs[itmp]) goto out_false
		 *     goto top_off
		 * out_true:
		 *     push 1
		 *     goto out
		 * out_false:
		 *     push 0
		 * out:
		 */
		emit_load_scalar(ltmp->idx);
		TclEmitOpcode(INST_LIST_LENGTH, L->frame->envPtr);
		emit_load_scalar(rtmp->idx);
		TclEmitOpcode(INST_LIST_LENGTH, L->frame->envPtr);
		emit_store_scalar(itmp->idx);
		TclEmitOpcode(INST_EQ, L->frame->envPtr);
		out_false = emit_jmp_fwd(INST_JUMP_FALSE4, out_false);
		top_off = currOffset(L->frame->envPtr);
		emit_load_scalar(itmp->idx);
		out_true = emit_jmp_fwd(INST_JUMP_FALSE4, out_true);
		TclEmitInstInt1(INST_INCR_SCALAR1_IMM, itmp->idx,
				L->frame->envPtr);
		TclEmitInt1(-1, L->frame->envPtr);
		emit_pop();
		emit_load_scalar(ltmp->idx);
		emit_load_scalar(itmp->idx);
		TclEmitOpcode(INST_LIST_INDEX, L->frame->envPtr);
		emit_load_scalar(rtmp->idx);
		emit_load_scalar(itmp->idx);
		TclEmitOpcode(INST_LIST_INDEX, L->frame->envPtr);
		compile_eq_stack(expr, type->base_type);
		out_false = emit_jmp_fwd(INST_JUMP_FALSE4, out_false);
		emit_jmp_back(TCL_UNCONDITIONAL_JUMP, top_off);
		fixup_jmps(&out_true);
		push_lit("1");
		out = emit_jmp_fwd(INST_JUMP1, out);
		fixup_jmps(&out_false);
		push_lit("0");
		fixup_jmps(&out);
		tmp_free(itmp);
		break;
	    case L_STRUCT:
		/*
		 * The structs are of compatible types, so we know
		 * they have the same number of members.  Compare
		 * them one by one.
		 */
		i = 0;
		for (v = type->u.struc.members; v; v = v->next) {
			emit_load_scalar(ltmp->idx);
			TclEmitInstInt4(INST_LIST_INDEX_IMM, i,
					L->frame->envPtr);
			emit_load_scalar(rtmp->idx);
			TclEmitInstInt4(INST_LIST_INDEX_IMM, i,
					L->frame->envPtr);
			++i;
			compile_eq_stack(expr, v->type);
			out_false = emit_jmp_fwd(INST_JUMP_FALSE4, out_false);
		}
		push_lit("1");
		out = emit_jmp_fwd(INST_JUMP1, out);
		fixup_jmps(&out_false);
		push_lit("0");
		fixup_jmps(&out);
		break;
	    case L_HASH:
		/*
		 *     if (length(lhs) != length(rhs)) goto out_false2
		 *     if [dict first lhs] goto out_true
		 * top_off:
		 *     // stack: val key (key is on top)
		 *     unless [::dict exists rhs key] goto out_false
		 *     unless [::dict get rhs key] == val goto out_false2
		 *     unless [dict next] goto top_off
		 * out_true:
		 *     pop   // pop key
		 *     pop   // pop val
		 *     push 1
		 *     goto out
		 * out_false:
		 *     pop   // pop key
		 *     pop   // pop val
		 * out_false2:
		 *     push 0
		 * out:
		 */
		itmp = tmp_get(TMP_UNSET);
		push_lit("::dict");
		push_lit("size");
		emit_load_scalar(ltmp->idx);
		// ::dict size lhs
		emit_invoke(3);
		// <lhs-size>
		push_lit("::dict");
		push_lit("size");
		emit_load_scalar(rtmp->idx);
		// <lhs-size> ::dict size rhs
		emit_invoke(3);
		// <lhs-size> <rhs-size>
		TclEmitOpcode(INST_EQ, L->frame->envPtr);
		// <true/false>
		out_false2 = emit_jmp_fwd(INST_JUMP_FALSE4, out_false2);
		emit_load_scalar(ltmp->idx);
		// lhs
		TclEmitInstInt4(INST_DICT_FIRST, itmp->idx, L->frame->envPtr);
		// <lhs-val> <lhs-key> <done-flag>
		out_true = emit_jmp_fwd(INST_JUMP_TRUE4, out_true);
		top_off = currOffset(L->frame->envPtr);
		// <lhs-val> <lhs-key>
		TclEmitOpcode(INST_DUP, L->frame->envPtr);
		// <lhs-val> <lhs-key> <lhs-key>
		push_lit("::dict");
		push_lit("exists");
		emit_load_scalar(rtmp->idx);
		// <lhs-val> <lhs-key> <lhs-key> ::dict exists rhs
		TclEmitInstInt1(INST_ROT, 3, L->frame->envPtr);
		// <lhs-val> <lhs-key> ::dict exists rhs <lhs-key>
		emit_invoke(4);
		// <lhs-val> <lhs-key> <rhs-exists-flag>
		out_false = emit_jmp_fwd(INST_JUMP_FALSE4, out_false);
		// <lhs-val> <lhs-key>
		push_lit("::dict");
		push_lit("get");
		emit_load_scalar(rtmp->idx);
		// <lhs-val> <lhs-key> ::dict get rhs
		TclEmitInstInt1(INST_ROT, 3, L->frame->envPtr);
		// <lhs-val> ::dict get rhs <lhs-key>
		emit_invoke(4);
		// <lhs-val> <rhs-val>
		compile_eq_stack(expr, type->base_type);
		// <equals-flag>
		out_false2 = emit_jmp_fwd(INST_JUMP_FALSE4, out_false2);
		TclEmitInstInt4(INST_DICT_NEXT, itmp->idx, L->frame->envPtr);
		// <lhs-val> <lhs-key> <done-flag>
		emit_jmp_back(TCL_FALSE_JUMP, top_off);
		fixup_jmps(&out_true);
		// <lhs-val> <lhs-key>
		emit_pop();
		emit_pop();
		push_lit("1");
		out = emit_jmp_fwd(INST_JUMP1, out);
		// <lhs-val> <lhs-key>
		fixup_jmps(&out_false);
		emit_pop();
		emit_pop();
		fixup_jmps(&out_false2);
		push_lit("0");
		fixup_jmps(&out);
		tmp_free(itmp);
		break;
	    default: ASSERT(0);
	}
	tmp_free(ltmp);
	tmp_free(rtmp);
}

private int
compile_keys(Expr *expr)
{
	int	n;

	push_lit("::dict");
	push_lit("keys");
	n = compile_exprs(expr->b, L_PUSH_VAL);
	unless (n == 1) {
		L_errf(expr, "incorrect # args to keys");
		expr->type = L_poly;
		return (0);  // stack effect
	}
	unless (ishash(expr->b) || ispoly(expr->b)) {
		L_errf(expr, "arg to keys is not a hash");
		expr->type = L_poly;
		return (0);  // stack effect
	}
	emit_invoke(3);
	if (ispoly(expr->b)) {
		expr->type = L_poly;
	} else {
		expr->type = type_mkArray(0, expr->b->type->u.hash.idx_type);
	}
	return (1);  // stack effect
}

private int
compile_length(Expr *expr)
{
	int	n;
	Jmp	*jmp1, *jmp2;

	expr->type = L_int;

	n = compile_exprs(expr->b, L_PUSH_VAL);
	unless (n == 1) {
		L_errf(expr, "incorrect # args to length");
		return (0);  // stack effect
	}
	if (isstring(expr->b) || iswidget(expr->b)) {
		TclEmitOpcode(INST_STR_LEN,  L->frame->envPtr);
	} else if (isarray(expr->b) || islist(expr->b) || ispoly(expr->b)) {
		TclEmitOpcode(INST_LIST_LENGTH, L->frame->envPtr);
	} else if (ishash(expr->b)) {
		/*
		 *    <arg is on stack from above compile_exprs>
		 *    dup
		 *    l_defined
		 *    jmpFalse 1
		 *    ::dict size (rot arg into place before the invoke)
		 *    jmp 2
		 * 1: pop
		 *    push 0
		 * 2:
		 */
		TclEmitOpcode(INST_DUP, L->frame->envPtr);
		TclEmitOpcode(INST_L_DEFINED, L->frame->envPtr);
		jmp1 = emit_jmp_fwd(INST_JUMP_FALSE1, NULL);
		push_lit("::dict");
		push_lit("size");
		TclEmitInstInt1(INST_ROT, 2, L->frame->envPtr);
		emit_invoke(3);
		jmp2 = emit_jmp_fwd(INST_JUMP1, NULL);
		fixup_jmps(&jmp1);
		emit_pop();
		push_lit("0");
		fixup_jmps(&jmp2);
	} else {
		L_errf(expr, "arg to length has illegal type");
	}
	return (1);  // stack effect
}

private int
compile_min_max(Expr *expr)
{
	push_litf("::tcl::mathfunc::%s", expr->a->str);
	unless (compile_exprs(expr->b, L_PUSH_VAL) == 2) {
		L_errf(expr, "incorrect # args to %s", expr->a->str);
		expr->type = L_poly;
		return (0);
	}
	L_typeck_expect(L_INT|L_FLOAT, expr->b, "in min/max");
	L_typeck_expect(L_INT|L_FLOAT, expr->b->next, "in min/max");
	emit_invoke(3);
	if (isfloat(expr->b) || isfloat(expr->b->next)) {
		expr->type = L_float;
	} else {
		expr->type = L_int;
	}
	return (1);  // stack effect
}

private int
compile_sort(Expr *expr)
{
	int	custom_compar = 0, i, n;
	Expr	*e, *l;
	Type	*t;

	/*
	 * Do some gymnastics to get this on the run-time stack:
	 * ::lsort
	 * <all args except last one>
	 * -integer, -real, or -ascii depending on list type, unless
	 *    the -compare option was given
	 * <last arg (the thing to be sorted)>
	 */

	push_lit("::lsort");
	n = compile_exprs(expr->b, L_PUSH_VAL);
	unless (n >= 1) {
		L_errf(expr, "incorrect # args to sort");
		expr->type = L_poly;
		return (0);  // stack effect
	}
	/* See if there's a "-command" argument. */
	for (i = 0, l = expr->b; i < (n-1); ++i, l = l->next) {
		unless (isconst(l) && l->str && !strcmp(l->str, "-command")) {
			continue;
		}
		/* Type check the arg to -command. */
		e = l->next;
		unless (e && (e->type->kind == L_NAMEOF) &&
			(e->type->base_type->kind == L_FUNCTION)) {
			L_errf(e, "'command:' arg to sort must be &function");
		}
		custom_compar = 1;
	}
	/* The last argument to sort must be an array, list, or poly. */
	if (isarray(l) || islist(l)) {
		t = l->type->base_type;
	} else if (ispoly(l)) {
		t = L_poly;
	} else {
		L_errf(expr, "last arg to sort not an array or list");
		expr->type = L_poly;
		return (0);  // stack effect
	}
	unless (custom_compar) {
		switch (t->kind) {
		    case L_INT:
			push_lit("-integer");
			break;
		    case L_FLOAT:
			push_lit("-real");
			break;
		    default:
			push_lit("-ascii");
			break;
		}
		TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr);
		++n;
	}
	if (n > 255) L_errf(expr, "sort cannot have >255 args");
	emit_invoke(n+1);
	expr->type = type_mkArray(0, t);
	return (1);  // stack effect
}

private int
compile_join(Expr *expr)
{
	Expr	*array, *sep;

	expr->type = L_string;
	push_lit("::join");
	unless ((sep=expr->b) && (array=sep->next) && !array->next) {
		L_errf(expr, "incorrect # args to join");
		return (0);  // stack effect
	}
	compile_expr(array, L_PUSH_VAL);
	unless (isarray(array) || islist(array) || ispoly(array)) {
		L_errf(expr, "second arg to join not an array or list");
		return (0);  // stack effect
	}
	compile_expr(sep, L_PUSH_VAL);
	unless (isstring(sep) || iswidget(sep) || ispoly(sep)) {
		L_errf(expr, "first arg to join not a string");
		return (0);  // stack effect
	}
	emit_invoke(3);
	return (1);  // stack effect
}

private int
compile_abs(Expr *expr)
{
	int	n;

	push_lit("::tcl::mathfunc::abs");
	n = compile_exprs(expr->b, L_PUSH_VAL);
	unless (n == 1) {
		L_errf(expr, "incorrect # args to abs");
		expr->type = L_poly;
		return (0);
	}
	unless (isint(expr->b) || isfloat(expr->b) || ispoly(expr->b)) {
		L_errf(expr, "must pass int or float to abs");
	}
	emit_invoke(2);
	expr->type = expr->b->type;
	return (1);  // stack effect
}

private int
compile_assert(Expr *expr)
{
	Jmp	*jmp;
	char	*cond_txt;

	expr->type = L_void;
	unless (expr->b && !expr->b->next) {
		L_errf(expr, "incorrect # args to assert");
		return (0);  // stack effect
	}
	compile_condition(expr->b);
	jmp = emit_jmp_fwd(INST_JUMP_TRUE4, NULL);
	cond_txt = get_text(expr->b);
	push_lit("die_");
	push_lit(frame_name());
	push_litf("%d", expr->node.loc.line);
	push_litf("ASSERTION FAILED %s:%d: %s\n", expr->node.loc.file,
		 expr->node.loc.line, cond_txt);
	emit_invoke(4);
	emit_pop();
	ckfree(cond_txt);
	fixup_jmps(&jmp);
	return (0);  // stack effect
}

private int
compile_catch(Expr *expr)
{
	L_errf(expr, "catch() is reserved for try/catch; "
	       "use ::catch() for Tcl's catch");
	return (0);
}

/*
 * Change die(fmt, ...args) into die_(__FILE__, __LINE__, fmt, ...args)
 */
private int
compile_die(Expr *expr)
{
	Expr	*arg;

	ckfree(expr->a->str);
	expr->a->str = ckstrdup("die_");
	arg = ast_mkId("__FILE__", expr->node.loc, expr->node.loc);
	arg->next = ast_mkId("__LINE__", expr->node.loc, expr->node.loc);
	arg->next->next = expr->b;
	expr->b = arg;
	return (compile_expr(expr, L_PUSH_VAL));
}

/*
 * Change warn(fmt, ...args) into warn_(__FILE__, __LINE__, fmt, ...args)
 */
private int
compile_warn(Expr *expr)
{
	Expr	*arg;

	ckfree(expr->a->str);
	expr->a->str = ckstrdup("warn_");
	arg = ast_mkId("__FILE__", expr->node.loc, expr->node.loc);
	arg->next = ast_mkId("__LINE__", expr->node.loc, expr->node.loc);
	arg->next->next = expr->b;
	expr->b = arg;
	return (compile_expr(expr, L_PUSH_VAL));
}

/*
 * Change here() into here_(__FILE__, __LINE__, __FUNC__)
 */
private int
compile_here(Expr *expr)
{
	Expr	*arg;

	if (expr->b) {
		L_errf(expr, "here() takes no arguments");
	}
	ckfree(expr->a->str);
	expr->a->str = ckstrdup("here_");
	arg = ast_mkId("__FILE__", expr->node.loc, expr->node.loc);
	arg->next = ast_mkId("__LINE__", expr->node.loc, expr->node.loc);
	arg->next->next = ast_mkId("__FUNC__", expr->node.loc, expr->node.loc);
	expr->b = arg;
	return (compile_expr(expr, L_PUSH_VAL));
}

private int
compile_undef(Expr *expr)
{
	int	n;
	Expr	*arg = expr->b;

	n = compile_exprs(arg, L_PUSH_PTR | L_DELETE | L_LVALUE);
	unless (n == 1) {
		L_errf(expr, "incorrect # args to undef");
		goto done;
	}
	unless (arg->sym) {
		L_errf(expr, "illegal l-value in undef()");
		goto done;
	}
	if (((arg->op == L_OP_DOT) || (arg->op == L_OP_POINTS)) &&
	    isstruct(arg->a)) {
		L_errf(expr, "cannot undef() a struct field");
		goto done;
	}
	/*
	 * If arg is a deep dive, delete the hash or array element.
	 * If arg is a variable, treat undef(var) like var=undef.
	 */
	if (arg->flags & L_EXPR_DEEP) {
		TclEmitInstInt4(INST_L_DEEP_WRITE,
				arg->sym->idx,
				L->frame->envPtr);
		TclEmitInt4(L_DELETE | L_DISCARD, L->frame->envPtr);
	} else {
		TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr);
		emit_store_scalar(arg->sym->idx);
		emit_pop();
	}
 done:
	expr->type = L_void;
	return (0);  // stack effect
}

private int
compile_typeof(Expr *expr)
{
	Sym	*sym;

	expr->type = L_string;
	unless (expr->b->kind == L_EXPR_ID) {
		L_errf(expr, "argument to typeof() not a variable");
		return (0);
	}
	sym = sym_lookup(expr->b, 0);
	if (sym) {
		if (sym->type->name) {
			push_lit(sym->type->name);
		} else {
			push_lit(L_type_str(sym->type->kind));
		}
	}
	return (1);  // stack effect
}

private int
compile_read(Expr *expr)
{
	int	n;
	Expr	*buf, *fd, *nbytes;

	expr->type = L_int;
	push_lit("Lread_");
	n = compile_exprs(expr->b, L_PUSH_VAL);
	unless ((n == 2) || (n == 3)) {
		L_errf(expr, "incorrect # args to read()");
		return (0);
	}
	fd = expr->b;
	unless (typeisf(fd, "FILE") || ispoly(fd)) {
		L_errf(expr, "first arg to read() must have type FILE");
		return (0);
	}
	buf = fd->next;
	unless (isaddrof(buf) && (isstring(buf->a) || ispoly(buf->a))) {
		L_errf(expr, "second arg to read() must have type string&");
		return (0);
	}
	nbytes = buf->next;
	if (nbytes) {
		unless (isint(nbytes) || ispoly(nbytes)) {
			L_errf(expr, "third arg to read() must have type int");
			return (0);
		}
	}
	emit_invoke(n+1);
	return (1);  // stack effect
}

private int
compile_write(Expr *expr)
{
	int	n;
	Expr	*buf, *fd, *nbytes;

	expr->type = L_int;
	push_lit("Lwrite_");
	n = compile_exprs(expr->b, L_PUSH_VAL);
	unless (n == 3) {
		L_errf(expr, "incorrect # args to write()");
		return (0);
	}
	fd = expr->b;
	unless (typeisf(fd, "FILE") || ispoly(fd)) {
		L_errf(expr, "first arg to write() must have type FILE");
		return (0);
	}
	buf = fd->next;
	unless (isstring(buf) || iswidget(buf) || ispoly(buf)) {
		L_errf(expr, "second arg to write() must have type string");
		return (0);
	}
	nbytes = buf->next;
	unless (isint(nbytes) || ispoly(nbytes)) {
		L_errf(expr, "third arg to write() must have type int");
		return (0);
	}
	emit_invoke(4);
	return (1);  // stack effect
}

/*
 * Allowable forms of system():
 *
 * int system(string cmd)
 * int system(string cmd, STATUS &s)
 * int system(string argv[])
 * int system(string argv[], STATUS &s)
 * int system(cmd | argv[], string in, string &out, string &err)
 * int system(cmd | argv[], string in, string &out, string &err, STATUS &)
 * int system(cmd | argv[], string[] in, string[] &out, string[] &err)
 * int system(cmd | argv[], string[] in, string[] &out, string[] &err,STATUS &)
 * int system(cmd | argv[], "input", "${outf}", "errors")
 * int system(cmd | argv[], "input", "${outf}", "errors", STATUS &s)
 * int system(cmd | argv[], FILE in, FILE out, FILE err);
 * int system(cmd | argv[], FILE in, FILE out, FILE err, STATUS &s);
 *
 * and spawn():
 *
 * int spawn(string cmd)
 * int spawn(string cmd, STATUS &s)
 * int spawn(string argv[])
 * int spawn(string argv[], STATUS &s)
 * int spawn(cmd | argv[], string in, FILE out, FILE err)
 * int spawn(cmd | argv[], string in, FILE out, FILE err, STATUS &s)
 * int spawn(cmd | argv[], string[] in, FILE out, FILE err)
 * int spawn(cmd | argv[], string[] in, FILE out, FILE err, STATUS &s)
 * int spawn(cmd | argv[], "input", "${outf}", "errors")
 * int spawn(cmd | argv[], "input", "${outf}", "errors", STATUS &s)
 * int spawn(cmd | argv[], FILE in, FILE out, FILE err)
 * int spawn(cmd | argv[], FILE in, FILE out, FILE err, STATUS &s)
 *
 * Convert these into a call to system_ or spawn_ that has exactly
 * seven args, the last being flags indicating the number and type of
 * what the user supplied.
 */

private int
compile_spawn_system(Expr *expr)
{
	int	flags = 0, n;
	Expr	*cmd;
	Expr	*err = NULL, *in = NULL, *out = NULL, *status = NULL;
	enum	{ SYSTEM, SPAWN } kind;

	kind = isid(expr->a, "system") ? SYSTEM : SPAWN;

	push_lit("system_");
	n = compile_exprs(expr->b, L_PUSH_VAL);

	expr->type = L_poly;
	cmd = expr->b;
	switch (n) {
	    case 1:
		TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr);
		TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr);
		TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr);
		TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr);
		break;
	    case 2:
		status = cmd->next;
		TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr);
		TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr);
		TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr);
		TclEmitInstInt1(INST_ROT, 3, L->frame->envPtr);
		break;
	    case 4:
		in  = cmd->next;
		out = in->next;
		err = out->next;
		TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr);
		break;
	    case 5:
		in  = cmd->next;
		out = in->next;
		err = out->next;
		status = err->next;
		break;
	    default:
		L_errf(expr, "incorrect # args");
		return (0);
	}
	if (isstring(cmd) || ispoly(cmd)) {
	} else if (isarrayof(cmd, L_STRING | L_POLY) || islist(cmd)) {
		flags |= SYSTEM_ARGV;
	} else {
		L_errf(expr, "first arg must be string or string array");
	}
	switch (kind) {
	    case SYSTEM: flags |= typeck_system(in, out, err); break;
	    case SPAWN:  flags |= typeck_spawn(in, out, err); break;
	}
	if (status) {
		Type	*base_type = status->type->base_type;
		unless (isid(status, "undef") ||
			(isnameoftype(status->type) &&
			 (ispolytype(base_type) || typeis(base_type, "STATUS")))) {
			L_errf(expr, "last arg must be of type STATUS &");
			return (0);
		}
	}
	push_litf("0x%x", flags);
	emit_invoke(7);
	expr->type = L_int;
	return (1);
}

private int
typeck_spawn(Expr *in, Expr *out, Expr *err)
{
	int	flags = 0;

	if (!in || isid(in, "undef")) {
	} else if (typeisf(in, "FILE")) {
		flags |= SYSTEM_IN_HANDLE;
	} else if (isstring(in) && (isconst(in) || isinterp(in))) {
		flags |= SYSTEM_IN_FILENAME;
	} else if (isstring(in) || ispoly(in)) {
		flags |= SYSTEM_IN_STRING;
	} else if (isarrayof(in, L_STRING | L_POLY) || islist(in)) {
		flags |= SYSTEM_IN_ARRAY;
	} else {
		L_errf(in, "second arg must be FILE, or "
		       "string constant/variable/array");
	}
	if (!out || isid(out, "undef")) {
	} else if (typeisf(out, "FILE")) {
		flags |= SYSTEM_OUT_HANDLE;
	} else if (isstring(out) && (isconst(out) || isinterp(out))) {
		flags |= SYSTEM_OUT_FILENAME;
	} else {
		L_errf(out, "third arg must be FILE, or string constant");
	}
	if (!err || isid(err, "undef")) {
	} else if (typeisf(err, "FILE")) {
		flags |= SYSTEM_ERR_HANDLE;
	} else if (isstring(err) && (isconst(err) || isinterp(err))) {
		flags |= SYSTEM_ERR_FILENAME;
	} else {
		L_errf(err, "fourth arg must be FILE, or string constant");
	}

	return (flags | SYSTEM_BACKGROUND);
}

private int
typeck_system(Expr *in, Expr *out, Expr *err)
{
	int	flags = 0;

	if (!in || isid(in, "undef")) {
	} else if (typeisf(in, "FILE")) {
		flags |= SYSTEM_IN_HANDLE;
	} else if (isstring(in) && (isconst(in) || isinterp(in))) {
		flags |= SYSTEM_IN_FILENAME;
	} else if (isstring(in) || ispoly(in)) {
		flags |= SYSTEM_IN_STRING;
	} else if (isarrayof(in, L_STRING | L_POLY) || islist(in)) {
		flags |= SYSTEM_IN_ARRAY;
	} else {
		L_errf(in, "second arg must be FILE, or "
		       "string constant/variable/array");
	}
	if (!out || isid(out, "undef")) {
	} else if (typeisf(out, "FILE")) {
		flags |= SYSTEM_OUT_HANDLE;
	} else if (isstring(out) && (isconst(out) || isinterp(out))) {
		flags |= SYSTEM_OUT_FILENAME;
	} else if (isaddrof(out) && (isstring(out->a) || ispoly(out->a))) {
		flags |= SYSTEM_OUT_STRING;
	} else if (isaddrof(out) && isarrayof(out->a, L_STRING | L_POLY)) {
		flags |= SYSTEM_OUT_ARRAY;
	} else {
		L_errf(out, "third arg must be FILE, string "
		       "constant, or reference to string or string array");
	}
	if (!err || isid(err, "undef")) {
	} else if (typeisf(err, "FILE")) {
		flags |= SYSTEM_ERR_HANDLE;
	} else if (isstring(err) && (isconst(err) || isinterp(err))) {
		flags |= SYSTEM_ERR_FILENAME;
	} else if (isaddrof(err) && (isstring(err->a) || ispoly(err->a))) {
		flags |= SYSTEM_ERR_STRING;
	} else if (isaddrof(err) && isarrayof(err->a, L_STRING | L_POLY)) {
		flags |= SYSTEM_ERR_ARRAY;
	} else {
		L_errf(err, "fourth arg must be FILE, string "
		       "constant, or reference to string or string array");
	}

	return (flags);
}

private int
compile_popen(Expr *expr)
{
	int	flags = 0, n;
	Expr	*cb, *cmd, *mode;
	VarDecl	*args;
	Type	*want;
	YYLTYPE	loc = { 0 };

	push_lit("popen_");
	expr->type = L_poly;

	n = compile_exprs(expr->b, L_PUSH_VAL);
	unless ((n == 2) || (n == 3)) {
		L_errf(expr, "incorrect # args to popen");
		return (0);
	}
	cmd  = expr->b;
	mode = cmd->next;
	cb   = mode->next;

	if (isarrayof(cmd, L_STRING | L_POLY) || islist(cmd)) {
		flags |= SYSTEM_ARGV;
	} else unless (isstring(cmd) || ispoly(cmd)) {
		L_errf(cmd, "first arg to popen must be string or string array");
	}

	L_typeck_expect(L_STRING, mode, "in second arg to popen");

	// To typecheck the optional stderr-callback arg, build a
	// type descriptor and let L_typeck_same() do the work.
	if (cb) {
		args = ast_mkVarDecl(L_string, NULL, loc, loc);
		args->next = ast_mkVarDecl(L_string, NULL, loc, loc);
		want = type_mkNameOf(type_mkFunc(L_void, args));
		unless (L_typeck_same(want, cb->type)) {
			L_errf(cb, "illegal type for stderr callback");
		}
		flags |= SYSTEM_OUT_HANDLE;
	} else {
		TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr);
	}

	push_litf("0x%x", flags);
	emit_invoke(5);
	expr->type = L_typedef_lookup("FILE");
	ASSERT(expr->type);
	return (1);
}

/*
 * Return a copy of the source text for the given expression.  Caller
 * must free.
 */
private char *
get_text(Expr *expr)
{
	int	beg = expr->node.loc.beg;
	int	end = expr->node.loc.end;
	int	len = end - beg;
	char	*s;

	s = ckalloc(len + 1);
	strncpy(s, Tcl_GetString(L->script)+beg, len);
	s[len] = 0;
	return (s);
}

/*
 * Emit code to compute the value of the given expression.  The flags
 * say in what form the generated code should produce the value.  The
 * caller chooses these flags based on whether
 * 1. expr will be read, written, or both; and whether
 * 2. expr is a deep dive or something else (an object dereference,
 *    a variable, or an expression).
 * The flags are bit-masks (see below) and can be combined.
 *
 * Passing in one of the pointer flags means that IF the expr is a
 * deep dive, leave a deep-ptr to it and possibly also its value on
 * the run-time stack.  If the expr is not, evaluate it (so that
 * expr->sym etc is valid) but don't push anything.  You use this when
 * expr is an l-value.
 *
 * Passing in L_PUSH_VAL and none of the pointer flags means that
 * the expr's value is left on the stack.
 *
 * Passing in both L_PUSH_VAL and one of the pointer flags is done
 * when the caller needs a deep-ptr if expr is a deep dive but
 * just wants the value otherwise.  You use this when expr is
 * an l-value but you also need the r-value, such as when
 * compiling ++/-- or =~.
 *
 * Passing in L_PUSH_NAME means the fully qualified name of the
 * variable is left on the stack and is valid only for certain
 * kinds of variables (globals, locals, class variables, or class
 * instance variables).
 *
 * L_PUSH_VAL		push value onto stack, unless deep dive and
 *			you also request a deep-ptr
 * L_PUSH_PTR		if deep dive, push deep-ptr onto stack
 * L_PUSH_PTRVAL	if deep dive, push deep-ptr then value onto stack
 * L_PUSH_VALPTR	if deep dive, push value then deep-ptr onto stack
 * L_LVALUE		if deep dive, create an un-shared copy for writing
 * L_DISCARD		evaluate expr then discard its value
 * L_PUSH_NAME		push fully qualified name of variable, not the value
 */
private int
compile_expr(Expr *expr, Expr_f flags)
{
	int	n = 0;
	int	start_off = currOffset(L->frame->envPtr);

	++L->expr_level;

	/* The compile_xxx returns indicate whether they pushed anything. */
	unless (expr) return (0);
	switch (expr->kind) {
	    case L_EXPR_FUNCALL:
		n = compile_fnCall(expr);
		break;
	    case L_EXPR_CONST:
	    case L_EXPR_RE:
		push_lit(expr->str);
		n = 1;
		break;
	    case L_EXPR_ID:
		n = compile_var(expr, flags);
		break;
	    case L_EXPR_UNOP:
		n = compile_unOp(expr);
		break;
	    case L_EXPR_BINOP:
		n = compile_binOp(expr, flags);
		break;
	    case L_EXPR_TRINOP:
		n = compile_trinOp(expr);
		break;
	    default:
		L_bomb("Unknown expression type %d", expr->kind);
	}

	/*
	 * Throw away the value if requested by the caller. This is done
	 * for expressions that are statements, in for-loop pre and
	 * post expressions, etc.
	 */
	if (flags & L_DISCARD) {
		while (n--) emit_pop();
	}

	track_cmd(start_off, expr);

	--L->expr_level;
	return (n);
}

/*
 * If a function-call name begins with a cap and has an _ inside, it
 * looks like a pattern call.  From a name like "Foo_barBazBlech"
 * create Expr const nodes "foo", "Foo_*" and a linked list of Expr
 * const nodes for "bar", "baz", and "blech".  Note that the returned
 * Expr's need not be freed explicitly since all AST nodes are
 * deallocated by the compiler.
 */
private int
ispatternfn(char *name, Expr **foo, Expr **Foo_star, Expr **opts, int *nopts)
{
	int	i;
	char	*buf, *p, *under;
	Expr	*e;

	unless ((name[0] >= 'A') && (name[0] <= 'Z') &&
		(p = strchr(name, '_')) && p[1]) {  // _ cannot be last
		return (FALSE);
	}

	under = p;
	*under = '\0';

	/* Build foo from Foo_bar. */
	buf = cksprintf("%s", name);
	buf[0] = tolower(buf[0]);
	*foo = mkId(buf);
	ckfree(buf);

	/* Build Foo_* from Foo_bar. */
	buf = cksprintf("%s_*", name);
	*Foo_star = mkId(buf);
	ckfree(buf);

	/* Build a list of bar,baz,blech nodes from barBazBlech. */
	++p;
	*opts  = NULL;
	*nopts = 0;
	while (*p) {
		YYLTYPE loc = { 0 };
		*p = tolower(*p);
		buf = ckalloc(strlen(p) + 1);
		for (i = 0; *p && !isupper(*p); ++p, ++i) {
			buf[i] = *p;
		}
		buf[i] = 0;
		e = ast_mkConst(L_string, buf, loc, loc);
		APPEND_OR_SET(Expr, next, *opts, e);
		++(*nopts);
	}

	*under = '_';

	return (TRUE);
}

/*
 * Rules for compiling a function call like "foo(arg)":
 *
 * - If foo is a variable of type name-of function, assume it contains
 *   the name of the function to call.
 *
 * - Otherwise call foo.  If foo isn't declared, that's OK, we just
 *   won't have a prototype to type-check against.
 *
 * For a function call like "Foo_bar(a,b,c)" or "Foo_barBazBlech(a,b,c)",
 * where the name starts with [A-Z] and has an _ in it (except at the
 * end), we have what's called a "pattern function".  The "bar", "baz",
 * and "blech" are the "options", and "a", "b", and "c" are the "arguments".
 *
 * - If Foo_bar happens to be a declared function, handle as above.
 *
 * - If the function Foo_* is defined, change the call to
 *   Foo_*(bar,baz,blech,a,b,c).
 *
 * - If "a" is not of widget type, change the call to
 *   foo(bar,baz,blech,a,b,c).
 *
 * - If "a" is a widget type, change the call to *a(bar,baz,blech,b,c)
 *   where *a means that the value of the argument "a" becomes the
 *   function name.
 */
private int
compile_fnCall(Expr *expr)
{
	int	expand, i, level, nopts;
	int	num_parms = 0, typchk = FALSE;
	char	*name;
	char	*defchk = NULL;  // name for definedness chk before main() runs
	Expr	*foo, *Foo_star, *opts, *p;
	Sym	*sym;
	VarDecl	*formals = NULL;

	ASSERT(expr->a->kind == L_EXPR_ID);
	name = expr->a->str;

	/* Check for an (expand) in the arg list. */
	expand = 0;
	for (p = expr->b; p; p = p->next) {
		if (isexpand(p)) {
			TclEmitOpcode(INST_EXPAND_START, L->frame->envPtr);
			expand = 1;
			break;
		}
	}

	/*
	 * Check for an L built-in function. XXX change the array to
	 * a hash if the number of built-ins grows much more.
	 */
	for (i = 0; i < sizeof(builtins)/sizeof(builtins[0]); ++i) {
		if (!strcmp(builtins[i].name, name)) {
			if (expand) {
				L_errf(expr, "(expand) illegal with "
				       "this function");
			}
			i = builtins[i].fn(expr);
			/* Copy out hash/array elements passed by reference. */
			copyout_parms(expr->b);
			return (i);
		}
	}

	level = fnCallBegin();
	sym = sym_lookup(expr->a, L_NOWARN);

	if (sym && isfntype(sym->type)) {
		/* A regular call -- the name is the fn name. */
		push_lit(sym->tclname);
		formals = sym->type->u.func.formals;
		typchk = TRUE;
		defchk = name;
		expr->type = sym->type->base_type;
	} else if (sym && (sym->type->kind == L_NAMEOF) &&
		   (sym->type->base_type->kind == L_FUNCTION)) {
		/*
		 * Name is a function "pointer".  It holds the function
		 * name and its type is the function proto.
		 */
		emit_load_scalar(sym->idx);
		formals = sym->type->base_type->u.func.formals;
		typchk = TRUE;
		expr->type = sym->type->base_type->base_type;
	} else if (sym) {
		/* Name is declared but isn't a function or fn pointer. */
		L_errf(expr, "'%s' is declared but not as a function", name);
		expr->type = L_poly;
	} else if (ispatternfn(name, &foo, &Foo_star, &opts, &nopts)) {
		/* Pattern function.  Figure out which kind. */
		if ((sym = sym_lookup(Foo_star, L_NOWARN))) {
			/* Foo_* is defined -- compile Foo_*(opts,a,b,c). */
			push_lit(Foo_star->str);
			APPEND(Expr, next, opts, expr->b);
			expr->b = opts;
			formals = sym->type->u.func.formals;
			typchk = TRUE;
			defchk = Foo_star->str;
			expr->type = sym->type->base_type;
		} else {
			/* Push first arg, then check its type. */
			compile_expr(expr->b, L_PUSH_VAL);
			if (!expr->b) {
				/* No args, compile as foo(opts). */
				push_lit(foo->str);
				num_parms = push_parms(opts, NULL);
				defchk = foo->str;
			} else if (iswidget(expr->b)) {
				/* Compile as *a(opts,b,c). */
				APPEND(Expr, next, opts, expr->b->next);
				expr->b = opts;
			} else {
				/* Compile as foo(opts,a,b,c). */
				// a
				push_lit(foo->str);
				num_parms = push_parms(opts, NULL);
				ASSERT(num_parms == nopts);
				// a foo <opts>
				TclEmitInstInt1(isexpand(expr->b)?
						    INST_EXPAND_ROT : INST_ROT,
						nopts + 1,
						L->frame->envPtr);
				// foo <opts> a
				expr->b = expr->b->next;
				++num_parms;
				defchk = foo->str;
			}
			expr->type = L_poly;
		}
	} else {
		/* Call to an undeclared function. */
		push_lit(name);
		expr->type = L_poly;
		defchk = name;
	}
	num_parms += push_parms(expr->b, formals);
	if (expand) {
		emit_invoke_expanded();
	} else {
		emit_invoke(num_parms+1);
	}

	/*
	 * Handle the copy-out part of copy in/out parameters.
	 * These are any deep-dive expressions that are passed by reference.
	 */
	copyout_parms(expr->b);

	if (typchk) L_typeck_fncall(formals, expr);
	fnCallEnd(level);
	/*
	 * If the call is to a function name that is known now (e.g.,
	 * not a function pointer), add it to the L->fn_calls list
	 * which is walked before main() is called to verify that the
	 * function exists.
	 */
	if (defchk) {
		Tcl_Obj *nm  = Tcl_NewStringObj(defchk, -1);
		Tcl_Obj *val = Tcl_NewObj();
		Tcl_DictObjPut(L->interp, L->fn_calls, nm, val);
		Tcl_SetVar2Ex(L->interp, "%%L_fnsCalled", NULL, L->fn_calls,
			      TCL_GLOBAL_ONLY);
	}
	return (1);  // stack effect
}

private void
copyout_parms(Expr *actuals)
{
	Expr	*actual, *arg;

	/*
	 * Copy out any deep-dive expressions that were passed with &.
	 * For these, the actual's value was copied into a temp var
	 * and its name passed.  Copy that temp back out.
	 */
	for (actual = actuals; actual; actual = actual->next) {
		arg = actual->a;
		unless (isaddrof(actual) && (arg->flags & L_SAVE_IDX)) {
			continue;
		}
		emit_load_scalar(arg->u.deepdive.val->idx);
		compile_assignFromStack(arg, arg->type, NULL, L_REUSE_IDX);
		emit_pop();
		tmp_free(arg->u.deepdive.val);
		arg->u.deepdive.val = NULL;
	}
}

private int
compile_var(Expr *expr, Expr_f flags)
{
	Sym	*self, *sym;

	ASSERT(expr->kind == L_EXPR_ID);

	/* Check for pre-defined identifiers first. */
	if (isid(expr, "END")) {
		TclEmitOpcode(INST_L_READ_SIZE, L->frame->envPtr);
		unless ((L->idx_op == L_OP_ARRAY_INDEX) |
			(L->idx_op == L_OP_ARRAY_SLICE)) {
			L_errf(expr,
			       "END illegal outside of a string or array index");
		}
		expr->type = L_int;
		return (1);
	} else if (isid(expr, "undef")) {
		TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr);
		expr->type = L_poly;
		return (1);
	} else if (isid(expr, "__FILE__")) {
		push_lit(expr->node.loc.file);
		expr->type = L_string;
		return (1);
	} else if (isid(expr, "__LINE__")) {
		push_litf("%d", expr->node.loc.line);
		expr->type = L_int;
		return (1);
	} else if (isid(expr, "__FUNC__")) {
		push_lit(frame_name());
		expr->type = L_string;
		return (1);
	}

	unless ((sym = sym_lookup(expr, flags))) {
		// Undeclared variable.
		expr->type = L_poly;
		return (1);
	}
	expr->type = sym->type;
	if (flags & L_PUSH_VAL) {
		if (sym->kind & L_SYM_FN) {
			L_errf(expr, "cannot use a function name as a value");
		} else {
			emit_load_scalar(sym->idx);
		}
		return (1);
	} else if (flags & L_PUSH_NAME) {
		switch (canDeref(sym)) {
		    case DECL_GLOBAL_VAR:
			if (sym->decl->flags & DECL_PRIVATE) {
				push_litf("::_%s_%s", L->toplev, sym->name);
			} else {
				push_litf("::%s", sym->name);
			}
			break;
		    case DECL_LOCAL_VAR:
			push_lit(sym->tclname);
			break;
		    case DECL_FN:
			push_lit(sym->tclname);
			break;
		    case DECL_CLASS_VAR:
			push_litf("::L::_class_%s::%s",
				 sym->decl->clsdecl->decl->id->str,
				 sym->name);
			break;
		    case DECL_CLASS_INST_VAR:
			self = sym_lookup(mkId("self"), L_NOWARN);
			ASSERT(self);
			emit_load_scalar(self->idx);
			push_litf("::%s", sym->name);
			TclEmitInstInt1(INST_STR_CONCAT1, 2, L->frame->envPtr);
			break;
		    default:
			ASSERT(0);
		}
		return (1);
	} else {
		/* Push nothing. */
		return (0);
	}
	/* Not reached. */
	ASSERT(0);
	return (1);
}

private int
compile_exprs(Expr *expr, Expr_f flags)
{
	int	num_exprs;

	for (num_exprs = 0; expr; expr = expr->next, ++num_exprs) {
		compile_expr(expr, flags);
	}
	return (num_exprs);
}

/*
 * Emit code to push the parameters to a function call and return the
 * # pushed.  Rules:
 *
 * - For two consecutive parms like "-foovariable, &foo", push "-foovariable"
 *   and then the name of "foo".  This is legal only for globals, class
 *   variables, and class instance variables.
 *
 * - If undef is passed as a reference parameter, pass the name of the
 *   special variable L_undef_ref_parm_.  Code in lib L sets read and
 *   write traces on this variable as a way to cause a run-time error
 *   upon access to it.
 *
 * - For everything else, push the value or name as indicated by whether
 *   the parm has the & operator; compile_expr() handles that.  The type
 *   checker sorts out any mis-matches with the declared formals.
 */
private int
push_parms(Expr *actuals, VarDecl *formals)
{
	int	i;
	int	widget_flag = FALSE;
	int	strlen_of_variable = strlen("variable");
	char	*s;
	Expr	*a, *v;
	Sym	*sym;

	for (i = 0, a = actuals; a; a = a->next, ++i) {
		if (isaddrof(a) && (a->a->kind == L_EXPR_ID) &&
		    (sym = sym_lookup(a->a, L_NOWARN)) &&
		    (sym->decl->flags & DECL_REF)) {
			push_lit(sym->tclname);
			a->type = type_mkNameOf(a->a->type);
		} else if (isid(a, "undef") &&
			   formals && isnameoftype(formals->type) &&
			   !isfntype(formals->type->base_type)) {
			push_lit("::L_undef_ref_parm_");
			a->type = L_poly;
		} else {
			compile_expr(a, L_PUSH_VAL);
		}
		if (widget_flag && isaddrof(a)) {
			a->type = L_poly;
			v = a->a;
			/* can't use local vars or functions from a widget */
			if (v->sym &&
			    ((v->sym->decl->flags & (DECL_LOCAL_VAR|DECL_FN)) ||
			    !canDeref(v->sym))) {
				L_errf(a, "illegal operand to &");
			}
		}
		s = a->str;
		widget_flag = ((a->kind == L_EXPR_CONST) &&
		    isstring(a) &&
		    /* has at least the minimum length */
		    (strlen(s) > strlen_of_variable) &&
		    /* starts with '-' */
		    (s[0] == '-') &&
		    /* ends with "variable" */
		    !strcmp("variable", s + (strlen(s) - strlen_of_variable)));
		if (formals) formals = formals->next;
	}
	return (i);
}

private int
compile_unOp(Expr *expr)
{
	switch (expr->op) {
	    case L_OP_BANG:
	    case L_OP_BITNOT:
		if (expr->op == L_OP_BANG) {
			compile_condition(expr->a);
		} else {
			compile_expr(expr->a, L_PUSH_VAL);
		}
		L_typeck_expect(L_INT, expr->a, "in unary ! or ~");
		emit_instrForLOp(expr, expr->type);
		expr->type = expr->a->type;
		break;
	    case L_OP_UPLUS:
	    case L_OP_UMINUS:
		compile_expr(expr->a, L_PUSH_VAL);
		L_typeck_expect(L_INT|L_FLOAT, expr->a, "in unary +/-");
		emit_instrForLOp(expr, expr->type);
		expr->type = expr->a->type;
		break;
	    case L_OP_DEFINED:
		compile_defined(expr->a);
		expr->type = L_int;
		break;
	    case L_OP_ADDROF:
		/*
		 * Compile &<expr>.  For function names, regular
		 * variables, and class variables (&x,
		 * &classname->var, &obj->var), this is just the name
		 * of the Tcl variable.  For a deep-dive expr,
		 * it's the name of a temp var that holds the value.
		 */
		compile_expr(expr->a, L_PUSH_NAME);
		expr->type = type_mkNameOf(expr->a->type);
		unless (expr->a->sym) {
			L_errf(expr->a, "illegal operand to &");
			expr->type = L_poly;
		}
		break;
	    case L_OP_PLUSPLUS_PRE:
	    case L_OP_PLUSPLUS_POST:
	    case L_OP_MINUSMINUS_PRE:
	    case L_OP_MINUSMINUS_POST:
		compile_incdec(expr);
		expr->type = expr->a->type;
		break;
	    case L_OP_EXPAND:
		unless (fnInArgList()) {
			L_errf(expr, "(expand) illegal in this context");
		}
		compile_expr(expr->a, L_PUSH_VAL);
		TclEmitInstInt4(INST_EXPAND_STKTOP,
				L->frame->envPtr->currStackDepth,
				L->frame->envPtr);
		expr->type = L_poly;
		break;
	    case L_OP_CMDSUBST:
		push_lit("::backtick_");
		if (expr->a) {
			compile_expr(expr->a, L_PUSH_VAL);
			push_lit(expr->str);
			TclEmitInstInt1(INST_STR_CONCAT1, 2, L->frame->envPtr);
		} else {
			push_lit(expr->str);
		}
		emit_invoke(2);
		expr->type = L_string;
		break;
	    case L_OP_FILE:
		if (expr->a) {
			push_lit("fgetline");
			compile_expr(expr->a, L_PUSH_VAL);
			if (typeisf(expr->a, "FILE")) {
				emit_invoke(2);
			} else {
				L_errf(expr->a, "expect FILE in <>");
			}
		} else {
			push_lit("angle_read_");
			emit_invoke(1);
		}
		expr->type = L_string;
		break;
	    default:
		L_bomb("Unknown unary operator %d", expr->op);
		break;
	}
	return (1);  // stack effect
}

private int
compile_binOp(Expr *expr, Expr_f flags)
{
	int	expand, level, n;
	Type	*type;
	Expr	*e;

	/* Return the net run-time stack effect (i.e., how much was pushed). */

	switch (expr->op) {
	    case L_OP_EQUALS:
		compile_assign(expr);
		expr->type = expr->a->type;
		return (1);
	    case L_OP_EQPLUS:
	    case L_OP_EQMINUS:
	    case L_OP_EQSTAR:
	    case L_OP_EQSLASH:
		compile_assign(expr);
		L_typeck_expect(L_INT|L_FLOAT, expr->a,
				"in arithmetic assignment");
		expr->type = expr->a->type;
		return (1);
	    case L_OP_EQPERC:
	    case L_OP_EQBITAND:
	    case L_OP_EQBITOR:
	    case L_OP_EQBITXOR:
	    case L_OP_EQLSHIFT:
	    case L_OP_EQRSHIFT:
		compile_assign(expr);
		L_typeck_expect(L_INT, expr->a, "in arithmetic assignment");
		expr->type = expr->a->type;
		return (1);
	    case L_OP_EQDOT:
		compile_assign(expr);
		L_typeck_expect(L_STRING|L_WIDGET, expr->a, "in .=");
		expr->type = expr->a->type;
		return (1);
	    case L_OP_ANDAND:
	    case L_OP_OROR:
		compile_shortCircuit(expr);
		expr->type = L_int;
		return (1);
	    case L_OP_STR_EQ:
	    case L_OP_STR_NE:
	    case L_OP_STR_GT:
	    case L_OP_STR_GE:
	    case L_OP_STR_LT:
	    case L_OP_STR_LE:
		unless (hash_get(L->options, "allow_eq_ops")) {
			L_errf(expr, "illegal comparison operator");
		}
		/* Warn on things like "s eq undef". */
		if (isid(e=expr->a, "undef") || isid(e=expr->b, "undef")) {
			L_errf(e, "undef illegal in comparison");
		}
		compile_expr(expr->a, L_PUSH_VAL);
		compile_expr(expr->b, L_PUSH_VAL);
		L_typeck_expect(L_STRING|L_WIDGET, expr->a,
				"in string comparison");
		L_typeck_expect(L_STRING|L_WIDGET, expr->b,
				"in string comparison");
		emit_instrForLOp(expr, expr->type);
		expr->type = L_int;
		return (1);
	    case L_OP_EQUALEQUAL:
	    case L_OP_NOTEQUAL:
	    case L_OP_GREATER:
	    case L_OP_GREATEREQ:
	    case L_OP_LESSTHAN:
	    case L_OP_LESSTHANEQ:
		expr->type = L_int;
		/* Warn on things like "i == undef". */
		if (isid(e=expr->a, "undef") || isid(e=expr->b, "undef")) {
			L_errf(e, "undef illegal in comparison");
		}
		compile_expr(expr->a, L_PUSH_VAL);
		compile_expr(expr->b, L_PUSH_VAL);
		L_typeck_deny(L_VOID, expr->a);
		L_typeck_deny(L_VOID, expr->b);
		unless (L_typeck_compat(expr->a->type, expr->b->type) ||
			L_typeck_compat(expr->b->type, expr->a->type)) {
			L_errf(expr, "incompatible types in comparison");
			return (0);
		}
		if (!isscalar(expr->a) && (expr->op != L_OP_EQUALEQUAL)) {
			L_errf(expr, "only eq() allowed on non-scalar types");
			return (0);
		}
		compile_eq_stack(expr, expr->a->type);
		return (1);  // stack effect
	    case L_OP_PLUS:
	    case L_OP_MINUS:
	    case L_OP_STAR:
	    case L_OP_SLASH:
		compile_expr(expr->a, L_PUSH_VAL);
		compile_expr(expr->b, L_PUSH_VAL);
		L_typeck_expect(L_INT|L_FLOAT, expr->a,
				"in arithmetic operator");
		L_typeck_expect(L_INT|L_FLOAT, expr->b,
				"in arithmetic operator");
		emit_instrForLOp(expr, expr->type);
		if (isfloat(expr->a) || isfloat(expr->b)) {
			expr->type = L_float;
		} else {
			expr->type = L_int;
		}
		return (1);
	    case L_OP_PERC:
	    case L_OP_BITAND:
	    case L_OP_BITOR:
	    case L_OP_BITXOR:
	    case L_OP_LSHIFT:
	    case L_OP_RSHIFT:
		compile_expr(expr->a, L_PUSH_VAL);
		compile_expr(expr->b, L_PUSH_VAL);
		L_typeck_expect(L_INT, expr->a, "in arithmetic operator");
		L_typeck_expect(L_INT, expr->b, "in arithmetic operator");
		emit_instrForLOp(expr, expr->type);
		expr->type = L_int;
		return (1);
	    case L_OP_ARRAY_INDEX:
	    case L_OP_HASH_INDEX:
	    case L_OP_DOT:
	    case L_OP_POINTS:
		return (compile_idxOp(expr, flags));
	    case L_OP_CLASS_INDEX:
		return (compile_clsDeref(expr, flags));
	    case L_OP_INTERP_STRING:
	    case L_OP_INTERP_RE:
		compile_expr(expr->a, L_PUSH_VAL);
		compile_expr(expr->b, L_PUSH_VAL);
		TclEmitInstInt1(INST_STR_CONCAT1, 2, L->frame->envPtr);
		expr->type = L_string;
		return (1);
	    case L_OP_LIST:
		level = fnCallBegin();
		for (e = expr, expand = 0; e; e = e->b) {
			if (e->a && isexpand(e->a)) {
				TclEmitOpcode(INST_EXPAND_START,
					      L->frame->envPtr);
				expand = 1;
				break;
			}
		}
		push_lit("::list");
		n = compile_expr(expr->a, L_PUSH_VAL);
		if (n == 0) {  // empty list {}
			ASSERT(!expr->a && !expr->b);
			type = L_poly;
		} else if (iskv(expr->a)) {
			ASSERT((n == 2) && ishash(expr->a));
			type = expr->a->type;
		} else {
			type = type_mkList(expr->a->type);
		}
		for (e = expr->b; e; e = e->b) {
			ASSERT(e->op == L_OP_LIST);
			n += compile_expr(e->a, L_PUSH_VAL);
			if (ishashtype(type) && iskv(e->a)) {
			} else if (islisttype(type) && !iskv(e->a)) {
				/*
				 * The list type is literally a list of all the
				 * individual element types linked together.
				 */
				Type *t = type_mkList(e->a->type);
				APPEND(Type, next, type, t);
			} else unless (ispolytype(type)) {
				L_errf(expr, "cannot mix hash and "
				       "non-hash elements");
				type = L_poly;
			}
		}
		if (expand) {
			emit_invoke_expanded();
		} else {
			emit_invoke(n+1);
		}
		expr->type = type;
		fnCallEnd(level);
		return (1);
	    case L_OP_KV:
		n  = compile_expr(expr->a, L_PUSH_VAL);
		n += compile_expr(expr->b, L_PUSH_VAL);
		ASSERT(n == 2);
		unless (isscalar(expr->a)) {
			L_errf(expr->a, "hash keys must be scalar");
		}
		expr->type = type_mkHash(expr->a->type, expr->b->type);
		return (n);
	    case L_OP_EQTWID:
	    case L_OP_BANGTWID:
		compile_twiddle(expr);
		expr->type = L_int;
		return (1);
	    case L_OP_COMMA:
		compile_expr(expr->a, L_DISCARD);
		compile_expr(expr->b, L_PUSH_VAL);
		expr->type = expr->b->type;
		return (1);
	    case L_OP_CAST:
		return (compile_cast(expr, flags));
	    case L_OP_CONCAT:
		compile_expr(expr->a, L_PUSH_VAL);
		compile_expr(expr->b, L_PUSH_VAL);
		L_typeck_expect(L_STRING|L_WIDGET, expr->a,
				"in lhs of . operator");
		L_typeck_expect(L_STRING|L_WIDGET, expr->b,
				"in rhs of . operator");
		TclEmitInstInt1(INST_STR_CONCAT1, 2, L->frame->envPtr);
		expr->type = L_string;
		return (1);
	    default:
		L_bomb("compile_binOp: malformed AST");
		return (1);
	}
}

private int
compile_cast(Expr *expr, Expr_f flags)
{
	int	range;
	Jmp	*jmp;
	Type	*type = (Type *)expr->a;

	flags &= ~L_DISCARD;
	if (flags & L_LVALUE) {
		compile_expr(expr->b, flags);
	} else if ((type->kind == L_INT) || (type->kind == L_FLOAT)) {
		range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE,
					     L->frame->envPtr);
		TclEmitInstInt4(INST_BEGIN_CATCH4, range, L->frame->envPtr);
		ExceptionRangeStarts(L->frame->envPtr, range);
		if (type->kind == L_INT) {
			push_lit("::tcl::mathfunc::int");
			compile_expr(expr->b, flags);
			emit_invoke(2);
		} else if (type->kind == L_FLOAT) {
			push_lit("::tcl::mathfunc::double");
			compile_expr(expr->b, flags);
			emit_invoke(2);
		}
		ExceptionRangeEnds(L->frame->envPtr, range);
		jmp = emit_jmp_fwd(INST_JUMP4, 0);
		/* error case */
		ExceptionRangeTarget(L->frame->envPtr, range, catchOffset);
		TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr);
		/* out */
		fixup_jmps(&jmp);
		TclEmitOpcode(INST_END_CATCH, L->frame->envPtr);
	} else {
		compile_expr(expr->b, flags);
	}
	L_typeck_deny(L_VOID|L_FUNCTION, expr->b);
	expr->sym   = expr->b->sym;
	expr->flags = expr->b->flags;
	expr->type  = type;
	return (1);
}

private int
compile_trinOp(Expr *expr)
{
	int	save, start_off;
	int	i = 0, n = 0;
	Jmp	*end_jmp, *false_jmp;

	switch (expr->op) {
	    case L_OP_EQTWID:
		compile_twiddleSubst(expr);
		expr->type = L_int;
		n = 1;
		break;
	    case L_OP_INTERP_STRING:
	    case L_OP_INTERP_RE:
		compile_expr(expr->a, L_PUSH_VAL);
		compile_expr(expr->b, L_PUSH_VAL);
		compile_expr(expr->c, L_PUSH_VAL);
		TclEmitInstInt1(INST_STR_CONCAT1, 3, L->frame->envPtr);
		expr->type = L_string;
		n = 1;
		break;
	    case L_OP_ARRAY_SLICE:
		compile_expr(expr->a, L_PUSH_VAL);
		if (isstring(expr->a) || iswidget(expr->a)) {
			push_lit("::string");
			push_lit("range");
			TclEmitInstInt1(INST_ROT, 2, L->frame->envPtr);
			expr->type = L_string;
			i = 5;
		} else if (isarray(expr->a) || islist(expr->a)) {
			push_lit("::lrange");
			TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr);
			expr->type = expr->a->type;
			i = 4;
		} else {
			L_errf(expr->a, "illegal type for slice");
			expr->type = L_poly;
		}
		if (has_END(expr->b) || has_END(expr->c)) {
			if (isstring(expr->a) || iswidget(expr->a)) {
				TclEmitOpcode(INST_L_PUSH_STR_SIZE,
					      L->frame->envPtr);
			} else {
				TclEmitOpcode(INST_L_PUSH_LIST_SIZE,
					      L->frame->envPtr);
			}
		}
		save = L->idx_op;
		L->idx_op = L_OP_ARRAY_SLICE;
		compile_expr(expr->b, L_PUSH_VAL);
		unless (isint(expr->b)) {
			L_errf(expr->b, "first slice index not an int");
		}
		compile_expr(expr->c, L_PUSH_VAL);
		unless (isint(expr->c)) {
			L_errf(expr->c, "second slice index not an int");
		}
		L->idx_op = save;
		if (has_END(expr->b) || has_END(expr->c)) {
			TclEmitOpcode(INST_L_POP_SIZE, L->frame->envPtr);
		}
		emit_invoke(i);
		n = 1;
		break;
	    case L_OP_TERNARY_COND:
		compile_condition(expr->a);
		false_jmp = emit_jmp_fwd(INST_JUMP_FALSE4, NULL);
		start_off = currOffset(L->frame->envPtr);
		n = compile_expr(expr->b, L_PUSH_VAL);
		end_jmp = emit_jmp_fwd(INST_JUMP4, NULL);
		track_cmd(start_off, expr->b);
		fixup_jmps(&false_jmp);
		start_off = currOffset(L->frame->envPtr);
		compile_expr(expr->c, L_PUSH_VAL);
		track_cmd(start_off, expr->c);
		fixup_jmps(&end_jmp);
		if (ispoly(expr->b) || ispoly(expr->c)) {
			expr->type = L_poly;
		} else if (L_typeck_same(expr->b->type, expr->c->type)) {
			expr->type = expr->b->type;
		} else if ((expr->b->type->kind & (L_INT|L_FLOAT)) &&
			   (expr->c->type->kind & (L_INT|L_FLOAT))) {
			expr->type = L_float;
		} else {
			L_errf(expr, "incompatible types in ? : expressions");
			expr->type = L_poly;
		}
		break;
	    default:
		L_bomb("compile_trinOp: malformed AST");
	}
	return (n);  // stack effect
}


/*
 * There are two kinds of defined():
 *   defined(&var) - var is a call-by-reference formal
 *   defined(expr) - otherwise
 */
private void
compile_defined(Expr *expr)
{
	Sym	*sym;

	if (isaddrof(expr)) {
		unless (expr->a->kind == L_EXPR_ID) {
			L_errf(expr, "arg to & not a call-by-reference parm");
			return;
		}
		sym = sym_lookup(expr->a, L_NOWARN);
		unless (sym && (sym->decl->flags & DECL_REF)) {
			L_errf(expr, "%s undeclared or not a "
			       "call-by-reference parm", expr->a->str);
			return;
		}
		push_lit("::L_undef_ref_parm_");
		TclEmitInstInt4(INST_DIFFERENT_OBJ, sym->idx, L->frame->envPtr);
	} else {
		compile_expr(expr, L_PUSH_VAL);
		L_typeck_deny(L_VOID, expr);
		TclEmitOpcode(INST_L_DEFINED, L->frame->envPtr);
	}
}

/*
 * Estimate how many submatches are in the given regexp.  These are
 * the sub-expressions within parens.  If the regexp includes an
 * interpolated string, we can't get this exact, so just assume
 * the maximum (9) in that case.
 */
private int
re_submatchCnt(Expr *re)
{
	int		n = 9;
	Tcl_Obj		*const_regexp;
	Tcl_RegExp	compiled;

	if (re->kind == L_EXPR_RE) {
		const_regexp = Tcl_NewStringObj(re->str, -1);
		Tcl_IncrRefCount(const_regexp);
		compiled = Tcl_GetRegExpFromObj(L->interp, const_regexp,
					TCL_REG_ADVANCED);
		Tcl_DecrRefCount(const_regexp);
		if (compiled) n = ((TclRegexp *)compiled)->re.re_nsub;
	}
	return (n);
}

/*
 * Determine whether a regexp is a constant (which can be matched with
 * a string comparison), a glob (use string-match bytecode), a simpler
 * regexp (no submatches, use the regexp bytecode), or a more complex
 * regexp which requires the ::regexp command.  If the regexp is
 * interpolated, we can't tell for sure, so assume the worst.  Also
 * return flags indicating whether the re expr needs to be compiled.
 *
 * If ds is non-NULL return the equivalent glob in *ds; this becomes
 * an operand to INST_STR_EQ or INST_STR_MATCH.
 */
private ReKind
re_kind(Expr *re, Tcl_DString *ds)
{
	Tcl_DString	myds;
	int		exact, ret = 0;

	unless ((re->kind == L_EXPR_RE) || (re->op == L_OP_INTERP_RE)) {
		return (RE_NOT_AN_RE);
	}
	unless (ds) ds = &myds;  // to accommodate passing in ds==NULL

	if (re->op == L_OP_INTERP_RE) {
		ret |= RE_NEEDS_EVAL;
	}
	if (re->flags & L_EXPR_RE_L) {
		ret |= RE_NEEDS_EVAL | RE_GLOB;
	} else if (re_submatchCnt(re) || (re->flags & L_EXPR_RE_G)) {
		ret |= RE_NEEDS_EVAL | RE_COMPLEX;
	} else if (isstring(re) &&
		   (TclReToGlob(NULL, re->str, strlen(re->str),
				ds, &exact, NULL) == TCL_OK) &&
		   exact) {
		if (ds == &myds) Tcl_DStringFree(&myds);
		ret |= RE_CONST;
	} else {
		ret |= RE_NEEDS_EVAL | RE_SIMPLE;
	}
	return (ret);
}

private void
compile_twiddle(Expr *expr)
{
	compile_expr(expr->a, L_PUSH_VAL);
	compile_reMatch(expr->b);
	if (expr->op == L_OP_BANGTWID) {
		TclEmitOpcode(INST_LNOT, L->frame->envPtr);
		L_typeck_expect(L_STRING|L_WIDGET, expr->a, "in !~");
	} else {
		L_typeck_expect(L_STRING|L_WIDGET, expr->a, "in =~");
	}
}

/*
 * Compile a regexp match.  It is assumed that the value to compare
 * the regexp against will already be on the run-time stack.  Code to
 * push the regexp is generated here.  When run, these are replaced
 * with the match Boolean.
 */
private void
compile_reMatch(Expr *re)
{
	int		i, cflags, mod_cnt, submatch_cnt;
	int		nocase = (re->flags & L_EXPR_RE_I);
	Sym		*s;
	Expr		*id;
	ReKind		kind;
	Tcl_DString	ds;

	kind = re_kind(re, &ds);
	/* First push the regexp. */
	if (kind & RE_NEEDS_EVAL) {
		compile_expr(re, L_PUSH_VAL);
	} else {
		push_lit(Tcl_DStringValue(&ds));
		Tcl_DStringFree(&ds);
	}
	/* Now emit the appropriate match instruction. */
	switch (kind & (RE_CONST|RE_GLOB|RE_SIMPLE|RE_COMPLEX)) {
	    case RE_CONST:
		TclEmitOpcode(INST_STR_EQ, L->frame->envPtr);
		break;
	    case RE_GLOB:
		TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr);
		TclEmitInstInt1(INST_STR_MATCH, nocase, L->frame->envPtr);
		break;
	    case RE_SIMPLE:
		TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr);
		cflags = TCL_REG_ADVANCED | TCL_REG_NLSTOP |
			(nocase ? TCL_REG_NOCASE : 0);
		TclEmitInstInt1(INST_REGEXP, cflags, L->frame->envPtr);
		break;
	    case RE_COMPLEX:
		// val re
		TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr);
		// re val
		push_lit("::regexp");
		mod_cnt = push_regexpModifiers(re);
		push_lit("--");
		// re val ::regexp <mods> --
		TclEmitInstInt1(INST_ROT, mod_cnt+3, L->frame->envPtr);
		// val ::regexp <mods> -- re
		TclEmitInstInt1(INST_ROT, mod_cnt+3, L->frame->envPtr);
		// ::regexp <mods> -- re val
		/* Submatch vars.  This loop always iterates at least once. */
		submatch_cnt = re_submatchCnt(re);
		for (i = 0; i <= submatch_cnt; i++) {
			char	buf[32];
			snprintf(buf, sizeof(buf), "$%d", i);
			id = mkId(buf);
			unless (sym_lookup(id, L_NOWARN)) {
				s = sym_mk(buf, L_string,
					   SCOPE_LOCAL | DECL_LOCAL_VAR);
				s->used_p = TRUE; // suppress unused var warning
			}
			push_lit(buf);
		}
		emit_invoke(5 + submatch_cnt + mod_cnt);
		break;
	    default: ASSERT(0);
	}
}

private void
compile_twiddleSubst(Expr *expr)
{
	Expr	*id, *lhs = expr->a;
	int	i, modCount, submatchCount;
	Sym	*s;
	Tmp	*tmp = NULL;
	Tcl_Obj	*varList;

	push_lit("::regsub");
	modCount = push_regexpModifiers(expr->b);
	/* Submatch vars.  This loop always iterates at least once. */
	push_lit("-submatches");
	submatchCount = re_submatchCnt(expr->b);
	varList = Tcl_NewObj();
	Tcl_IncrRefCount(varList);
	for (i = 0; i <= submatchCount; i++) {
		char	buf[32];
		snprintf(buf, sizeof(buf), "$%d", i);
		id = mkId(buf);
		unless (sym_lookup(id, L_NOWARN)) {
			s = sym_mk(buf, L_string,
				   SCOPE_LOCAL | DECL_LOCAL_VAR);
			s->used_p = TRUE; // suppress unused var warning
		}
		Tcl_AppendPrintfToObj(varList, "$%d ", i);
	}
	push_lit(Tcl_GetString(varList));
	Tcl_DecrRefCount(varList);
	push_lit("-line");
	push_lit("--");
	compile_expr(expr->b, L_PUSH_VAL);
	// ::regsub <mods> -submatches <varlist> -line -- <re>
	compile_expr(expr->c, L_PUSH_VAL);
	// ::regsub <mods> -submatches <varlist> -line -- <re> <subst>
	compile_expr(lhs, L_PUSH_VALPTR | L_PUSH_VAL | L_LVALUE);
	unless (lhs->sym) {
		L_errf(expr, "invalid l-value in =~");
		return;
	}
	if (isdeepdive(lhs)) {
		tmp = tmp_get(TMP_REUSE);
		// ::regsub <mods> -submatches <varlist>
		// -line -- <re> <subst> <lhs-val> <lhs-ptr>
		TclEmitInstInt1(INST_ROT, -(8+modCount), L->frame->envPtr);
		// <lhs-ptr> ::regsub <mods> -submatches <varlist>
		// -line -- <re> <subst> <lhs-val>
		TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr);
		// <lhs-ptr> ::regsub <mods> -submatches <varlist>
		// -line -- <re> <lhs-val> <subst>
		push_lit(tmp->name);
		// <lhs-ptr> ::regsub <mods> -submatches <varlits>
		// -line -- <re> <lhs-val> <subst> <tmp-name>
	} else {
		// ::regsub <mods> -submatches <varlist>
		// -line -- <re> <subst> <lhs-val>
		TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr);
		// ::regsub <mods> -submatches <varlist>
		// -line -- <re> <lhs-val> <subst>
		push_lit(lhs->sym->tclname);
		// ::regsub <mods> -submatches <varlist>
		// -line -- <re> <lhs-val> <subst> <lhs-name>
	}
	emit_invoke(modCount + 9);
	if (isdeepdive(lhs)) {
		// <lhs-ptr> <match>
		emit_load_scalar(tmp->idx);
		tmp_free(tmp);
		// <lhs-ptr> <match> <new-val>
		TclEmitInstInt1(INST_ROT, 2, L->frame->envPtr);
		// <match> <new-val> <lhs-ptr>
		TclEmitInstInt4(INST_L_DEEP_WRITE,
				lhs->sym->idx,
				L->frame->envPtr);
		TclEmitInt4(L_PUSH_NEW, L->frame->envPtr);
		// <match> <new-val>
		emit_pop();
	}
	L_typeck_expect(L_STRING|L_WIDGET, lhs, "in =~");
	// <match>
}

private void
compile_shortCircuit(Expr *expr)
{
	Jmp	*jmp;
	unsigned char op;

	/*
	 * In case the operator "a op b" short-circuits, we need one
	 * value of "a" on the stack for the test and one for the value of
	 * the expression.  If the operator doesn't short-circuit, we
	 * pop one of these off and move on to evaluating "b".
	 */
	ASSERT((expr->op == L_OP_ANDAND) || (expr->op == L_OP_OROR));
	op = (expr->op == L_OP_ANDAND) ? INST_JUMP_FALSE4 : INST_JUMP_TRUE4;
	compile_condition(expr->a);
	// <a-val>
	TclEmitOpcode(INST_DUP, L->frame->envPtr);
	// <a-val> <a-val>
	jmp = emit_jmp_fwd(op, NULL);
	// <a-val>   if short-circuit and we jumped out
	// <a-val>   if did not short-circuit and we're still going
	emit_pop();
	compile_condition(expr->b);
	fixup_jmps(&jmp);
	// <a-val>   if short-circuit
	// <b-val>   if did not short-circuit
}

/*
 * Compile an expression that is used as a conditional test.
 * This is compiled like a normal expression except that if it's
 * of string type the expression is tested for defined.
 */
private void
compile_condition(Expr *cond)
{
	unless (cond) {
		push_lit("1");
		return;
	}
	if (isaddrof(cond)) {
		compile_defined(cond);
	} else {
		compile_expr(cond, L_PUSH_VAL);
		if (isvoid(cond)) {
			L_errf(cond, "void type illegal in predicate");
		}
		unless (isint(cond) || isfloat(cond) || ispoly(cond)) {
			TclEmitOpcode(INST_L_DEFINED, L->frame->envPtr);
		}
	}
	cond->type = L_int;
}

/*
 * Compile if-unless as follows.
 *
 * No "else" leg:          "Else" leg present:
 *    <eval cond>              <eval cond>
 *    jmpFalse 1               jmpFalse 1
 *    <if leg>                 <if leg>
 * 1:                          jmp 2
 *                          1: <else leg>
 *                          2:
 */
private void
compile_ifUnless(Cond *cond)
{
	Jmp	*endjmp, *falsejmp;

	/* Test the condition and jmp if false. */
	compile_condition(cond->cond);
	falsejmp = emit_jmp_fwd(INST_JUMP_FALSE4, NULL);

	/* Compile the "if" leg. */
	frame_push(cond, NULL, SEARCH);
	compile_stmts(cond->if_body);

	if (cond->else_body) {
		/* "Else" leg present. */
		frame_pop();
		frame_push(cond, NULL, SEARCH);
		endjmp = emit_jmp_fwd(INST_JUMP4, NULL);
		fixup_jmps(&falsejmp);
		compile_stmts(cond->else_body);
		fixup_jmps(&endjmp);
	} else {
		/* No "else" leg. */
		fixup_jmps(&falsejmp);
	}
	frame_pop();
}

private void
compile_loop(Loop *loop)
{
	switch (loop->kind) {
	    case L_LOOP_DO:
		compile_do(loop);
		break;
	    case L_LOOP_FOR:
	    case L_LOOP_WHILE:
		compile_for_while(loop);
		break;
	    default:
		L_bomb("bad loop type");
		break;
	}
}

/*
 * Do loop:
 *
 * 1: <body>
 *    <cond>
 *    jmpTrue 1
 */
private void
compile_do(Loop *loop)
{
	int	body_off;
	Jmp	*break_jmps, *continue_jmps;

	body_off = currOffset(L->frame->envPtr);
	frame_push(loop, NULL, LOOP|SEARCH);
	compile_stmts(loop->body);
	break_jmps    = L->frame->break_jumps;
	continue_jmps = L->frame->continue_jumps;
	frame_pop();
	fixup_jmps(&continue_jmps);

	compile_condition(loop->cond);
	emit_jmp_back(TCL_TRUE_JUMP, body_off);
	fixup_jmps(&break_jmps);
}

/*
 * While loop:        For loop:
 *
 *                      <pre>
 * 1: <cond>         1: <cond>
 *    jmpFalse 2        jmpFalse 2
 *    <body>            <body>
 *                      <post>
 *    jmp 1             jmp 1
 * 2:                2:
 */
private void
compile_for_while(Loop *loop)
{
	int	cond_off;
	Jmp	*break_jmps, *continue_jmps, *out_jmp;

	if (loop->kind == L_LOOP_FOR) compile_exprs(loop->pre, L_DISCARD);

	cond_off = currOffset(L->frame->envPtr);
	compile_condition(loop->cond);
	out_jmp = emit_jmp_fwd(INST_JUMP_FALSE4, NULL);

	frame_push(loop, NULL, LOOP|SEARCH);
	compile_stmts(loop->body);
	break_jmps    = L->frame->break_jumps;
	continue_jmps = L->frame->continue_jumps;
	frame_pop();
	fixup_jmps(&continue_jmps);

	if (loop->kind == L_LOOP_FOR) compile_exprs(loop->post, L_DISCARD);

	emit_jmp_back(TCL_UNCONDITIONAL_JUMP, cond_off);
	fixup_jmps(&out_jmp);
	fixup_jmps(&break_jmps);
}

/*
 * Emit a jump instruction to a backwards target.  jmp_type is one of
 * TCL_UNCONDITIONAL, TCL_TRUE_JUMP, or TCL_FALSE_JUMP.  The jump
 * opcope is appropriately selected for the jump distance.
 */
private void
emit_jmp_back(TclJumpType jmp_type, int offset)
{
	int	op = 0;
	int	dist = currOffset(L->frame->envPtr) - offset;

	if (dist > 127) {
		switch (jmp_type) {
		    case TCL_UNCONDITIONAL_JUMP:
			op = INST_JUMP4;
			break;
		    case TCL_TRUE_JUMP:
			op = INST_JUMP_TRUE4;
			break;
		    case TCL_FALSE_JUMP:
			op = INST_JUMP_FALSE4;
			break;
		    default:
			L_bomb("bad jmp type");
			break;
		}
		TclEmitInstInt4(op, -dist, L->frame->envPtr);
	} else {
		switch (jmp_type) {
		    case TCL_UNCONDITIONAL_JUMP:
			op = INST_JUMP1;
			break;
		    case TCL_TRUE_JUMP:
			op = INST_JUMP_TRUE1;
			break;
		    case TCL_FALSE_JUMP:
			op = INST_JUMP_FALSE1;
			break;
		    default:
			L_bomb("bad jmp type");
			break;
		}
		TclEmitInstInt1(op, -dist, L->frame->envPtr);
	}
}

/*
 * Emit a jump instruction with an unknown target offset and return a
 * structure that can be passed in to fixup_jmps() to later fix-up the
 * target to any desired bytecode offset.  Caller must free the
 * returned structure.
 */
private Jmp *
emit_jmp_fwd(int op, Jmp *next)
{
	Jmp	*ret = (Jmp *)ckalloc(sizeof(Jmp));

	ret->op     = op;
	ret->offset = currOffset(L->frame->envPtr);
	ret->next   = next;
	switch (op) {
	    case INST_JUMP1:
	    case INST_JUMP_TRUE1:
	    case INST_JUMP_FALSE1:
		ret->size = 1;
		TclEmitInstInt1(op, 0, L->frame->envPtr);
		break;
	    case INST_JUMP4:
	    case INST_JUMP_TRUE4:
	    case INST_JUMP_FALSE4:
		ret->size = 4;
		TclEmitInstInt4(op, 0, L->frame->envPtr);
		break;
	    default:
		L_bomb("unexpected jump instruction");
		break;
	}
	return (ret);
}

/*
 * Fix up jump targets to point to the current PC, free the
 * passed-in fix-ups list and then set it to NULL.
 */
private void
fixup_jmps(Jmp **p)
{
	int	target;
	Jmp	*t;
	Jmp	*j = *p;
	unsigned char *jmp_pc;

	while (j) {
		target = currOffset(L->frame->envPtr) - j->offset;
		jmp_pc = L->frame->envPtr->codeStart + j->offset;
		switch (j->size) {
		    case 1:
			ASSERT(*jmp_pc == j->op);
			TclUpdateInstInt1AtPc(j->op, target, jmp_pc);
			break;
		    case 4:
			ASSERT(*jmp_pc == j->op);
			TclUpdateInstInt4AtPc(j->op, target, jmp_pc);
			break;
		    default:
			L_bomb("unexpected jump fixup");
			break;
		}
		t = j->next;
		ckfree((char *)j);
		j = t;
	}
	*p = NULL;
}

private void
compile_foreach(ForEach *loop)
{
	/*
	 * Handle foreach(s in <expr>).
	 */
	if (loop->expr->op == L_OP_FILE) {
		compile_foreachAngle(loop);
		return;
	}

	compile_expr(loop->expr, L_PUSH_VAL);

	switch (loop->expr->type->kind) {
	    case L_ARRAY:
	    case L_LIST:
		compile_foreachArray(loop);
		break;
	    case L_HASH:
		compile_foreachHash(loop);
		break;
	    case L_STRING:
		compile_foreachString(loop);
		break;
	    default:
		L_errf(loop->expr, "foreach expression must be"
		       " array, hash, or string");
		break;
	}
}

/*
 * Most of the following function came from tclCompCmds.c
 * TclCompileForEachCmd(), modified in various ways for L.
 */
private void
compile_foreachArray(ForEach *loop)
{
	int		i, continue_off, num_vars;
	Expr		*var;
	ForeachInfo	*info;
	ForeachVarList	*varlist;
	Jmp		*break_jumps, *continue_jumps, *false_jump;
	int		jumpBackDist, jumpBackOffset, infoIndex;
	Tmp		*loopctrTmp, *valTmp;

	/* The foreach(k=>v in expr) form is illegal in array iteration. */
	if (loop->value) {
		L_errf(loop, "=> illegal in foreach over arrays");
	}

	/*
	 * Type-check the value variables.  In "foreach (v1,v2,v3 in
	 * a)", v* are the value variables or variable list, and a is
	 * the value list, in tcl terminology.
	 */
	for (var = loop->key, num_vars = 0; var; var = var->next, ++num_vars) {
		unless (sym_lookup(var, 0)) return;  // undeclared var
		unless (L_typeck_arrElt(var->type, loop->expr->type)) {
			L_errf(var, "loop index type incompatible with"
				    " array element type");
		}
	}

	/* Temps for value list value and loop counter. */
	valTmp = tmp_get(TMP_UNSET);
	loopctrTmp = tmp_get(TMP_UNSET);

	/*
	 * ForeachInfo and ForeachVarList are structures required by
	 * the bytecode interpreter for foreach bytecodes.  In our
	 * case, we have only one value and one variable list
	 * consisting of num_vars variables.
	 */
	info = (ForeachInfo *)ckalloc(sizeof(ForeachInfo) +
	    sizeof(ForeachVarList *));
	info->numLists       = 1;
	info->firstValueTemp = valTmp->idx;
	info->loopCtTemp     = loopctrTmp->idx;
	varlist = (ForeachVarList *)ckalloc(sizeof(ForeachVarList) +
	    num_vars * sizeof(int));
	varlist->numVars = num_vars;
	for (i = 0, var = loop->key; var; var = var->next, ++i) {
		Sym *s = sym_lookup(var, 0);
		varlist->varIndexes[i] = s->idx;
	}
	info->varLists[0] = varlist;
	infoIndex = TclCreateAuxData(info, &tclForeachInfoType,
				     L->frame->envPtr);

	/* The values to iterate through are already on the stack (the
	 * caller evaluated loop->expr).  Assign to the value temp. */
	emit_store_scalar(valTmp->idx);
	emit_pop();

	/* Initialize the loop state. */
	TclEmitInstInt4(INST_FOREACH_START4, infoIndex, L->frame->envPtr);

	/* Top of the loop.  Step, and jump out if done. */
	continue_off = currOffset(L->frame->envPtr);
	TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, L->frame->envPtr);
	false_jump = emit_jmp_fwd(INST_JUMP_FALSE4, NULL);

	/* Loop body. */
	frame_push(loop, NULL, LOOP|SEARCH);
	compile_stmts(loop->body);
	break_jumps    = L->frame->break_jumps;
	continue_jumps = L->frame->continue_jumps;
	frame_pop();
	fixup_jmps(&continue_jumps);

	/* End of loop -- jump back to top. */
	jumpBackOffset = currOffset(L->frame->envPtr);
	jumpBackDist   = jumpBackOffset - continue_off;
	if (jumpBackDist > 120) {
		TclEmitInstInt4(INST_JUMP4, -jumpBackDist, L->frame->envPtr);
	} else {
		TclEmitInstInt1(INST_JUMP1, -jumpBackDist, L->frame->envPtr);
	}

	fixup_jmps(&false_jump);

	/* Set the value variables to undef. */
	TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr);
	for (var = loop->key; var; var = var->next) {
		Sym *s = sym_lookup(var, 0);
		ASSERT(s);
		emit_store_scalar(s->idx);
	}
	emit_pop();

	fixup_jmps(&break_jumps);
	tmp_free(valTmp);
	tmp_free(loopctrTmp);
}

private void
compile_foreachHash(ForEach *loop)
{
	Sym	*key;
	Sym	*val = NULL;
	int	body_off, disp;
	Jmp	*break_jumps, *continue_jumps, *out_jmp;
	Tmp	*itTmp;

	/* Check types and ensure variables are declared etc. */
	unless ((key = sym_lookup(loop->key, 0))) return;
	if (loop->value) {
		unless ((val = sym_lookup(loop->value, 0))) return;
		unless (L_typeck_compat(val->type,
					loop->expr->type->base_type)) {
			L_errf(loop->value, "loop index value type "
			       "incompatible with hash element type");
		}
	}
	unless (L_typeck_compat(key->type, loop->expr->type->u.hash.idx_type)) {
		L_errf(loop->key,
		       "loop index key type incompatible with hash index type");
	}
	if (loop->key->next) {
		L_errf(loop, "multiple variables illegal in foreach over hash");
	}

	/* A temp to hold the iterator state.*/
	itTmp = tmp_get(TMP_UNSET);

	/*
	 * Both DICT_FIRST and DICT_NEXT leave value, key, and done-p
	 * on the stack.  Check done-p and jump out of the loop if
	 * it's true. (We fixup the jump target once we know the size
	 * of the loop body.)
	 */
	TclEmitInstInt4(INST_DICT_FIRST, itTmp->idx, L->frame->envPtr);
	out_jmp = emit_jmp_fwd(INST_JUMP_TRUE4, NULL);

	/*
	 * Update the key and value variables. We save the offset of
	 * this code so we can jump back to it after DICT_NEXT.
	 * Note: the caller already pushed loop->expr.
	 */
	body_off = currOffset(L->frame->envPtr);
	emit_store_scalar(key->idx);
	emit_pop();
	if (loop->value) emit_store_scalar(val->idx);
	emit_pop();

	/*
	 * Compile loop body.  Note that we must grab the jump fix-ups
	 * out of the frame before popping it.
	 */
	frame_push(loop, NULL, LOOP|SEARCH);
	compile_stmts(loop->body);
	break_jumps    = L->frame->break_jumps;
	continue_jumps = L->frame->continue_jumps;
	frame_pop();
	fixup_jmps(&continue_jumps);

	/* If there's another entry in the hash, go around again. */
	TclEmitInstInt4(INST_DICT_NEXT, itTmp->idx, L->frame->envPtr);
	disp = body_off - currOffset(L->frame->envPtr);
	TclEmitInstInt4(INST_JUMP_FALSE4, disp, L->frame->envPtr);

	/* End of the loop.  Point the jump after the DICT_FIRST to here. */
	fixup_jmps(&out_jmp);

	/* All done.  Cleanup the values that DICT_FIRST/DICT_NEXT left. */
	emit_pop();
	emit_pop();

	/* Set key and/or value counters to undef. */
	TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr);
	emit_store_scalar(key->idx);
	if (val) emit_store_scalar(val->idx);
	emit_pop();

	fixup_jmps(&break_jumps);
	/* XXX We need to ensure that DICT_DONE happens in the face of
	   exceptions, so that the refcount on the dict will be
	   decremented, and the iterator freed.  See the
	   implementation of "dict for" in tclCompCmds.c.  --timjr
	   2006.11.3 */
	TclEmitInstInt4(INST_DICT_DONE, itTmp->idx, L->frame->envPtr);
	tmp_free(itTmp);
}

/*
 * Foreach over a string uses three temp variables (str_idx, len_idx,
 * and it_idx) and compiles to this:
 *
 *    str_idx = string value already on stack
 *    len_idx = [::string length $str_idx]
 *    it_idx  = 0
 *    jmp 2
 * 1: loopvar1 = str_idx[it_idx++]
 *    loopvar2 = str_idx[it_idx++]
 *    ...
 *    loopvarn = str_idx[it_idx++]
 *    <loop body>
 * 2: test it_idx < len_idx
 *    jmp if true to 1
 */
private void
compile_foreachString(ForEach *loop)
{
	int	body_off, jmp_dist;
	Jmp	*break_jmps, *continue_jmps;
	Jmp	*cond_jmp = 0;
	Expr	*id;
	Tmp	*itTmp, *lenTmp, *strTmp;

	/* The foreach(k=>v in expr) form is illegal in string iteration. */
	if (loop->value) {
		L_errf(loop, "=> illegal in foreach over strings");
	}

	/* Temps for the loop index, string value, and string length. */
	itTmp  = tmp_get(TMP_REUSE);
	lenTmp = tmp_get(TMP_REUSE);
	strTmp = tmp_get(TMP_REUSE);

	emit_store_scalar(strTmp->idx);

	push_lit("::string");
	push_lit("length");
	TclEmitInstInt1(INST_ROT, 2, L->frame->envPtr);
	emit_invoke(3);
	emit_store_scalar(lenTmp->idx);
	emit_pop();

	push_lit("0");
	emit_store_scalar(itTmp->idx);
	emit_pop();

	cond_jmp = emit_jmp_fwd(INST_JUMP4, NULL);
	body_off = currOffset(L->frame->envPtr);

	for (id = loop->key; id; id = id->next) {
		unless (sym_lookup(id, 0)) return;  // undeclared var
		unless (L_typeck_compat(id->type, L_string)) {
			L_errf(id, "loop index not of string type");
		}
		emit_load_scalar(strTmp->idx);
		emit_load_scalar(itTmp->idx);
		TclEmitInstInt4(INST_L_INDEX, L_IDX_STRING | L_PUSH_VAL,
				L->frame->envPtr);
		emit_store_scalar(id->sym->idx);
		emit_pop();
		TclEmitInstInt1(INST_INCR_SCALAR1_IMM, itTmp->idx,
				L->frame->envPtr);
		TclEmitInt1(1, L->frame->envPtr);
		emit_pop();
	}

	frame_push(loop, NULL, LOOP|SEARCH);
	compile_stmts(loop->body);
	break_jmps    = L->frame->break_jumps;
	continue_jmps = L->frame->continue_jumps;
	frame_pop();
	fixup_jmps(&continue_jmps);

	fixup_jmps(&cond_jmp);
	emit_load_scalar(itTmp->idx);
	emit_load_scalar(lenTmp->idx);
	TclEmitOpcode(INST_LT, L->frame->envPtr);
	jmp_dist = currOffset(L->frame->envPtr) - body_off;
	TclEmitInstInt4(INST_JUMP_TRUE4, -jmp_dist, L->frame->envPtr);

	/* Set the loop counters to undef. */
	TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr);
	for (id = loop->key; id; id = id->next) {
		emit_store_scalar(id->sym->idx);
	}
	emit_pop();

	fixup_jmps(&break_jmps);
	tmp_free(itTmp);
	tmp_free(lenTmp);
	tmp_free(strTmp);
}

private void
compile_foreachAngle(ForEach *loop)
{
	Expr	*expr = loop->expr->a;
	Expr	*id;
	Tmp	*tmp;
	Jmp	*break_jmps, *continue_jmps, *out_jmp;
	int	top_off;

	/* Outlaw foreach(s in <>). */
	unless (expr) {
		L_errf(loop, "this form is disallowed; did you mean "
		       "while (buf = <>)?");
		return;
	}

	/* The foreach(k=>v in expr) form is illegal in string iteration. */
	if (loop->value) {
		L_errf(loop, "=> illegal in foreach over strings");
	}

	push_lit("LgetNextLineInit_");
	compile_expr(expr, L_PUSH_VAL);

	/* Outlaw foreach(s in <a_FILE>). */
	if (typeisf(expr, "FILE")) {
		L_errf(loop->expr,
		       "this form is disallowed; did you mean "
		       "while (buf = <F>)?");
		return;
	}
	unless (isstring(expr)) {
		L_errf(expr, "in foreach, arg to <> must be a string");
		return;
	}

	for (id = loop->key; id; id = id->next) {
		unless (sym_lookup(id, 0)) return;  // undeclared var
		unless (L_typeck_compat(id->type, L_string)) {
			L_errf(id, "loop index %s not of string type", id->str);
		}
	}

	/*
	 *    tmp = LgetNextLineInit_(expr)
	 * 1: s1 = LgetNextLine_(tmp)
	 *    s2 = LgetNextLine_(tmp)
	 *    ...
	 *    s<n> = LgetNextLine_(tmp)
	 *    if (s1 is undef) jmp 2
	 *    <loop body>
	 *    jmp 1
	 * 2:
	 */

	tmp = tmp_get(TMP_REUSE);
	emit_invoke(2);
	emit_store_scalar(tmp->idx);
	emit_pop();
	top_off = currOffset(L->frame->envPtr);
	for (id = loop->key; id; id = id->next) {
		push_lit("LgetNextLine_");
		emit_load_scalar(tmp->idx);
		emit_invoke(2);
		emit_store_scalar(id->sym->idx);
		emit_pop();
	}
	emit_load_scalar(loop->key->sym->idx);
	TclEmitOpcode(INST_L_DEFINED, L->frame->envPtr);
	out_jmp = emit_jmp_fwd(INST_JUMP_FALSE4, NULL);
	frame_push(loop, NULL, LOOP|SEARCH);
	compile_stmts(loop->body);
	break_jmps    = L->frame->break_jumps;
	continue_jmps = L->frame->continue_jumps;
	frame_pop();
	fixup_jmps(&continue_jmps);
	emit_jmp_back(TCL_UNCONDITIONAL_JUMP, top_off);
	fixup_jmps(&break_jmps);
	fixup_jmps(&out_jmp);
}

private void
compile_switch(Switch *sw)
{
	Case	*c;

	/*
	 * If all cases are constant, compile a jump table (fast),
	 * otherwise compile if-then-else code (slower).
	 */
	for (c = sw->cases; c; c = c->next) {
		if (c->expr && !isconst(c->expr)) break;
	}
	if (c) {
		compile_switch_slow(sw);
	} else {
		compile_switch_fast(sw);
	}
}

/*
 * Generate if-then-else code like the following for a switch statement.
 *
 *	local_tmp = <switch expression>
 * # The following is generated for each case except the default case.
 * # All jmps are forward jmps.
 * next-test:
 *	load local_tmp
 *	<case expression>
 *	<appropriate compare opcode>
 *	jmp-false next-test
 * next-body:
 *	<case body>
 *	jmp next-body
 * # The following is generated for the default case.
 *	jmp next-test
 * next-body:
 * default:
 *	<case body>
 *	jmp next-body
 * # Statement prologue.
 * next-test:
 *	jmp default   # backward jmp, only if default case present
 * next-body:
 * break-label:  # where break stmts jmp to
 *	pop
 */
private void
compile_switch_slow(Switch *sw)
{
	Expr	*e = sw->expr;
	Case	*c;
	int	def_off = -1;
	int	start_off;
	Jmp	*break_jmps;
	Jmp	*next_body_jmp = NULL, *next_test_jmp = NULL, *undef_jmp = NULL;
	Tmp	*tmp;

	compile_expr(e, L_PUSH_VAL);
	tmp = tmp_get(TMP_REUSE);
	emit_store_scalar(tmp->idx);
	emit_pop();
	unless (istype(e, L_INT|L_STRING|L_WIDGET|L_POLY)) {
		L_errf(e, "switch expression must be int or string");
		return;
	}

	frame_push(sw, NULL, SWITCH|SEARCH);
	/*
	 * If there's a case undef, check that first, because if the
	 * switch expr is undef, Tcl will still let us get its value
	 * and it would match a "" case and we don't want that.
	 */
	for (c = sw->cases; c; c = c->next) {
		if (c->expr && isid(c->expr, "undef")) {
			start_off = currOffset(L->frame->envPtr);
			emit_load_scalar(tmp->idx);
			TclEmitOpcode(INST_L_DEFINED, L->frame->envPtr);
			undef_jmp = emit_jmp_fwd(INST_JUMP_FALSE4, NULL);
			track_cmd(start_off, c->expr);
			break;
		}
	}
	for (c = sw->cases; c; c = c->next) {
		start_off = currOffset(L->frame->envPtr);
		if (c->expr && isid(c->expr, "undef")) {
			next_test_jmp = emit_jmp_fwd(INST_JUMP4, next_test_jmp);
			fixup_jmps(&undef_jmp);
		} else if (c->expr) {
			fixup_jmps(&next_test_jmp);
			emit_load_scalar(tmp->idx);
			if (isregexp(c->expr)) {
				compile_reMatch(c->expr);
			} else if (isint(e)) {
				compile_expr(c->expr, L_PUSH_VAL);
				TclEmitOpcode(INST_EQ, L->frame->envPtr);
			} else {
				compile_expr(c->expr, L_PUSH_VAL);
				TclEmitOpcode(INST_STR_EQ, L->frame->envPtr);
			}
			unless (L_typeck_compat(e->type, c->expr->type)) {
				L_errf(c, "case type incompatible"
				       " with switch expression");
			}
			next_test_jmp = emit_jmp_fwd(INST_JUMP_FALSE4,
						     next_test_jmp);
			track_cmd(start_off, c->expr);
		} else {  // default case (grammar ensures there's at most one)
			next_test_jmp = emit_jmp_fwd(INST_JUMP4, next_test_jmp);
			ASSERT(def_off == -1);
			def_off = currOffset(L->frame->envPtr);
			track_cmd(start_off, c);
		}
		fixup_jmps(&next_body_jmp);
		compile_stmts(c->body);
		next_body_jmp = emit_jmp_fwd(INST_JUMP4, NULL);
	}
	fixup_jmps(&next_test_jmp);
	if (def_off != -1) {
		emit_jmp_back(TCL_UNCONDITIONAL_JUMP, def_off);
	}
	fixup_jmps(&next_body_jmp);
	break_jmps = L->frame->break_jumps;
	frame_pop();
	fixup_jmps(&break_jmps);
	tmp_free(tmp);
}

/*
 * Generate jump-table code like the following for a switch statement.
 *
 *	<switch expression>
 *      INST_JUMP_TABLE
 *      jmp default
 * # The following is generated for each case except the default case.
 * # All jmps are forward jmps.
 * next-body:
 *      <case body>
 *      jmp next-body
 * # The following is the default case.
 * default:
 * next-body:
 *      <case body>     (only if default case present)
 *      jmp next-body   (only if default case present)
 * # Statement prologue.
 * next-body:
 * break-label:  # where break stmts jmp to
 */
private void
compile_switch_fast(Switch *sw)
{
	Expr		*e = sw->expr;
	Case		*c;
	int		jt_idx, new, start_off;
	Jmp		*break_jmps;
	Jmp		*default_jmp;
	Jmp		*next_body_jmp = NULL;
	Tcl_HashEntry	*hPtr;
	JumptableInfo	*jt;

	jt = (JumptableInfo *)ckalloc(sizeof(JumptableInfo));
	Tcl_InitHashTable(&jt->hashTable, TCL_STRING_KEYS);
	jt_idx = TclCreateAuxData(jt, &tclJumptableInfoType, L->frame->envPtr);

	compile_expr(e, L_PUSH_VAL);
	unless (istype(e, L_INT|L_STRING|L_WIDGET|L_POLY)) {
		L_errf(e, "switch expression must be int or string");
		return;
	}
	if (isint(e)) {
		/*
		 * Since the jump table keys are strings, add 0 to
		 * guarantee a canonicalized string rep of an int.
		 */
		push_lit("0");
		TclEmitOpcode(INST_ADD, L->frame->envPtr);
	}

	frame_push(sw, NULL, SWITCH|SEARCH);

	start_off = currOffset(L->frame->envPtr);
	TclEmitInstInt4(INST_JUMP_TABLE, jt_idx, L->frame->envPtr);
	default_jmp = emit_jmp_fwd(INST_JUMP4, NULL);

	for (c = sw->cases; c; c = c->next) {
		if (c->expr) {
			ASSERT(isconst(c->expr));
			hPtr = Tcl_CreateHashEntry(&jt->hashTable,
						   c->expr->str,
						   &new);
			if (new) {
				Tcl_SetHashValue(hPtr,
				    INT2PTR(currOffset(L->frame->envPtr) -
					    start_off));
			} else {
				L_errf(c, "duplicate case value");
			}
			unless (L_typeck_compat(e->type, c->expr->type)) {
				L_errf(c,
			      "case type incompatible with switch expression");
			}
		} else {  // default case (grammar ensures there's at most one)
			fixup_jmps(&default_jmp);
		}
		fixup_jmps(&next_body_jmp);
		compile_stmts(c->body);
		next_body_jmp = emit_jmp_fwd(INST_JUMP4, NULL);
	}
	fixup_jmps(&default_jmp); // no-op if default exists (already fixed up)
	fixup_jmps(&next_body_jmp);
	break_jmps = L->frame->break_jumps;
	frame_pop();
	fixup_jmps(&break_jmps);
}

private VarDecl *
struct_lookupMember(Type *t, Expr *idx, int *offset)
{
	VarDecl *m;

	ASSERT((idx->op == L_OP_DOT) || (idx->op == L_OP_POINTS));

	unless (t->u.struc.members) {
		L_errf(idx, "incomplete struct type %s", t->u.struc.tag);
		return (NULL);
	}
	for (*offset = 0, m = t->u.struc.members; m; m = m->next, ++*offset) {
		if (!strcmp(idx->str, m->id->str)) {
			return (m);
		}
	}
	return (NULL);
}

/*
 * Determine whether an array index expression contains a reference to
 * the array's END index.
 */
private int
has_END(Expr *expr)
{
	Expr	*p;

	unless (expr) return (0);
	switch (expr->kind) {
	    case L_EXPR_FUNCALL:
		for (p = expr->b; p; p = p->next) {
			if (has_END(p)) return (1);
		}
		return (0);
	    case L_EXPR_CONST:
	    case L_EXPR_RE:
		return (0);
	    case L_EXPR_ID:
		return (isid(expr, "END"));
	    case L_EXPR_UNOP:
		return (has_END(expr->a));
	    case L_EXPR_BINOP:
		switch (expr->op) {
		    case L_OP_ARRAY_INDEX:
			/* END in a nested index refers to another array. */
			return (has_END(expr->a));
		    case L_OP_CAST:
			/* A cast is special: expr->a is a type not an expr. */
			return (has_END(expr->b));
		    default:
			return (has_END(expr->a) || has_END(expr->b));
		}
	    case L_EXPR_TRINOP:
		if (expr->op == L_OP_ARRAY_SLICE) {
			/* END in a nested index refers to another array. */
			return (has_END(expr->a));
		} else {
			return (has_END(expr->a) || has_END(expr->b) ||
				has_END(expr->c));
		}
	    default: ASSERT(0);
	}
	/*NOTREACHED*/
	return (0);
}

/*
 * Generate code to push an array/hash/struct/string index onto the stack.
 * Return flags suitable for the INST_L_INDEX instruction which indicate
 * whether the operator is an array, hash, struct, or string index.
 */
private int
push_index(Expr *expr, int flags)
{
	int	ret;
	int	reuse = flags & L_REUSE_IDX;
	int	save  = flags & L_SAVE_IDX;
	Type	*type;
	VarDecl *member;
	Tmp	*idxTmp;
	int	offset;

	/* Error-path return values. */
	ret  = 0;
	type = L_poly;

	ASSERT(type);
	switch (expr->op) {
	    case L_OP_DOT:
	    case L_OP_POINTS:
		unless (isstruct(expr->a)) {
			L_errf(expr, "not a struct");
			goto out;
		}
		member = struct_lookupMember(expr->a->type,
					     expr,
					     &offset);
		if (member) {
			unless (reuse) push_litf("%i", offset);
			type = member->type;
		} else {
			L_errf(expr, "struct field %s not found", expr->str);
		}
		ret = L_IDX_ARRAY;
		break;
	    case L_OP_ARRAY_INDEX:
		unless (reuse) {
			compile_expr(expr->b, L_PUSH_VAL);
			if (isid(expr->b, "undef")) {
				L_errf(expr->b, "cannot use undef as an "
				       "array/string index");
			}
		}
		L_typeck_expect(L_INT, expr->b, "in array/string index");
		if (isarray(expr->a) || islist(expr->a)) {
			type = expr->a->type->base_type;
			ret  = L_IDX_ARRAY;
		} else if (isstring(expr->a) || iswidget(expr->a)) {
			/*
			 * Disallow stringvar[0][0] = "x". It doesn't make much
			 * sense and INST_L_DEEP_WRITE can't handle it anyway.
			 */
			if ((expr->a->op == L_OP_ARRAY_INDEX) &&
			    expr->a->sym &&
			    isstring(expr->a->a) &&
			    (expr->a->flags & L_LVALUE)) {
				L_errf(expr, "cannot index a string index");
			}
			type = L_string;
			ret  = L_IDX_STRING;
		} else if (ispoly(expr->a)) {
			type = L_poly;
			ret  = L_IDX_ARRAY;
		} else {
			L_errf(expr, "not an array or string");
		}
		break;
	    case L_OP_HASH_INDEX: {
		unless (reuse) {
			compile_expr(expr->b, L_PUSH_VAL);
			if (isid(expr->b, "undef")) {
				L_errf(expr->b, "cannot use undef as a "
				       "hash index");
			}
		}
		if (ishash(expr->a)) {
			L_typeck_expect(expr->a->type->u.hash.idx_type->kind,
					expr->b,
					"in hash index");
			type = expr->a->type->base_type;
		} else if (ispoly(expr->a)) {
			type = L_poly;
		} else {
			L_errf(expr, "not a hash");
		}
		ret = L_IDX_HASH;
		break;
	    }
	    default:
		L_bomb("Invalid index op, %d", expr->op);
		break;
	}
 out:
	if (save) {
		// save copy of index to a temp
		idxTmp = tmp_get(TMP_REUSE);
		expr->u.deepdive.idx = idxTmp;
		emit_store_scalar(idxTmp->idx);
	} else if (reuse) {
		// get index value from temp
		idxTmp = expr->u.deepdive.idx;
		ASSERT(idxTmp);
		emit_load_scalar(idxTmp->idx);
		tmp_free(idxTmp);
		expr->u.deepdive.idx = NULL;
	}
	expr->type = type;
	return (ret);
}

/*
 * Compile a hash/array/struct/class or string index.  These are the
 * L_OP_HASH_INDEX, L_OP_ARRAY_INDEX, L_OP_DOT, and L_OP_POINTS nodes.
 *
 * The resulting stack depends on the flags which specify whether the
 * indexed element's value, pointer, or both (and in what order) are
 * wanted.  We get one of
 *
 * <elem-obj>                  if flags & L_PUSH_VAL
 * <deep-ptr>                  if flags & L_PUSH_PTR
 * <elem-obj> <deep-ptr>       if flags & L_PUSH_VAL_PTR
 * <deep-ptr> <elem-obj>       if flags & L_PUSH_PTR_VAL
 * <tmp-name>                  if flags & L_PUSH_NAME
 *
 * For L_PUSH_NAME, we evaluate the indexed expression and store its
 * value and all the indices in local temp variables, then use the
 * value temp's name as the value of the expression.  The expr nodes
 * store information about the temps so they can be accessed later,
 * such as for the copy-out part of copy in/out parameters.
 */
private int
compile_idxOp(Expr *expr, Expr_f flags)
{
	int	ret;
	Tmp	*valTmp;

	if ((flags & L_PUSH_NAME) && !(flags & L_SAVE_IDX)) {
		/* First time through for L_PUSH_NAME. */
		ret = compile_idxOp2(expr, flags | L_PUSH_VAL | L_SAVE_IDX);
		/*
		 * Check whether this was really an object index (we
		 * don't know until now).
		 */
		if (isclass(expr->a)) return (ret);
		valTmp = tmp_get(TMP_REUSE);
		expr->u.deepdive.val = valTmp;
		emit_store_scalar(valTmp->idx);
		emit_pop();
		push_lit(valTmp->name);
	} else {
		ret = compile_idxOp2(expr, flags);
	}
	return (ret);
}

private int
compile_idxOp2(Expr *expr, Expr_f flags)
{
	int	save;

	/*
	 * Eval the thing being indexed.  The flags magic here is
	 * because we always want its value if it's a variable, or a
	 * deep-pointer if it's the result of another deep-dive index,
	 * regardless of in what form we want expr.
	 */
	compile_expr(expr->a, L_PUSH_PTR | L_PUSH_VAL |
		     (flags & ~(L_PUSH_VALPTR |
				L_PUSH_PTRVAL |
				L_DISCARD |
				L_PUSH_NAME)));

	/*
	 * Require "->" for all objects and call-by-reference structures.
	 * Require "." for all call-by-value and non-parameter structures.
	 */
	if (isclass(expr->a)) {
		unless (expr->op == L_OP_POINTS) {
			L_errf(expr, "must access object only with ->");
		}
	} else if (expr->a->sym &&
		   (expr->a->sym->decl->flags & DECL_REF) &&
		   !(expr->a->flags & L_EXPR_DEEP)) {
		if (expr->op == L_OP_DOT) {
			L_errf(expr, ". illegal on call-by-reference "
			       "parms; use -> instead");
		}
	} else {
		if (expr->op == L_OP_POINTS) {
			L_errf(expr, "-> illegal except on call-by-reference "
			       "parms; use . instead");
		}
	}

	/*
	 * Handle obj->var.  We check here because, in general, we
	 * don't know until now whether expr->a has type class.
	 */
	if (isclass(expr->a) && ((expr->op == L_OP_DOT) ||
				 (expr->op == L_OP_POINTS))) {
		return (compile_clsInstDeref(expr, flags));
	}

	if (has_END(expr->b)) {
		if (flags & L_REUSE_IDX) {
		} else if (isstring(expr->a) || iswidget(expr->a)) {
			TclEmitOpcode(INST_L_PUSH_STR_SIZE, L->frame->envPtr);
		} else {
			TclEmitOpcode(INST_L_PUSH_LIST_SIZE, L->frame->envPtr);
		}
	}

	save = L->idx_op;
	L->idx_op = expr->op;
	flags |= push_index(expr, flags);
	L->idx_op = save;

	if (has_END(expr->b)) {
		TclEmitOpcode(INST_L_POP_SIZE, L->frame->envPtr);
	}

	/*
	 * Perform an optimization and don't create a deep pointer if
	 * the caller won't be doing a deep dive into the expression
	 * being evaluated but instead just needs its value.  This
	 * happens when the deep dive we're doing now results in
	 * something of type class and the caller requested a value.
	 * See the comments in compile_expr().
	 *
	 * This wart is here because the caller can't know in general
	 * whether expr is a deep dive or a class deref.  Their
	 * expressions look identical but are evaluated in drastically
	 * different ways.
	 */
	if (isclass(expr) && (flags & (L_PUSH_VAL | L_DISCARD))) {
		flags &= ~(L_PUSH_PTR | L_PUSH_VALPTR | L_PUSH_PTRVAL |
			   L_LVALUE);
	} else if (flags & (L_PUSH_PTR | L_PUSH_VALPTR | L_PUSH_PTRVAL)) {
		flags &= ~L_PUSH_VAL;
	}

	TclEmitInstInt4(INST_L_INDEX, flags, L->frame->envPtr);

	/*
	 * Adjust the stack depth that Tcl tracks (debug build) to
	 * reflect when two objs are left on the stack instead of one
	 * as indicated by the entry in the tclInstructionTable in
	 * tclCompile.c
	 */
	if (flags & (L_PUSH_PTRVAL | L_PUSH_VALPTR)) {
		TclAdjustStackDepth(1, L->frame->envPtr);
	}

	expr->sym   = expr->a->sym;  // propagate sym table ptr up the tree
	expr->flags = flags | L_EXPR_DEEP;
	return ((flags & L_DISCARD) ? 0 : 1);
}

/* Compile classname->var. */
private int
compile_clsDeref(Expr *expr, Expr_f flags)
{
	int	in_class = 0;
	char	*clsnm, *varnm;
	Sym	*sym, *tmpsym;
	Tmp	*tmp;
	Type	*type    = (Type *)expr->a;
	ClsDecl	*clsdecl = type->u.class.clsdecl;
	Tcl_HashEntry *hPtr;

	expr->type = L_poly;
	unless (isclasstype(type)) {
		L_errf(expr, "can dereference only class types");
		return (0);
	}

	ASSERT(type && clsdecl);

	clsnm = clsdecl->decl->id->str;
	varnm = expr->str;
	if (L->enclosing_func) {
		in_class = L->enclosing_func->decl->flags & DECL_CLASS_FN;
	}

	hPtr = Tcl_FindHashEntry(clsdecl->symtab, varnm);
	unless (hPtr) {
		L_errf(expr, "%s is not a member of class %s", varnm, clsnm);
		return (0);
	}
	sym = (Sym *)Tcl_GetHashValue(hPtr);
	unless (in_class || (sym->decl->flags & DECL_PUBLIC)) {
		L_errf(expr, "%s is not a public variable of class %s",
		       varnm, clsnm);
	}
	unless (sym->decl->flags & DECL_CLASS_VAR) {
		L_errf(expr, "%s is not a class variable of class %s",
		       varnm, clsnm);
	}

	if (flags & L_PUSH_NAME) {
		push_litf("::L::_class_%s::%s", clsnm, sym->name);
		expr->sym  = sym;
		expr->type = sym->type;
		return (1);  // stack effect
	}

	tmp = tmp_get(TMP_UNSET);
	tmpsym = sym_mk(tmp->name, sym->type, SCOPE_LOCAL | DECL_LOCAL_VAR);
	ASSERT(tmpsym);  // cannot be multiply declared
	tmpsym->used_p = TRUE;

	push_litf("::L::_class_%s", clsnm);
	push_lit(sym->name);
	TclEmitInstInt4(INST_NSUPVAR, tmp->idx, L->frame->envPtr);
	emit_pop();

	expr->sym  = tmpsym;
	expr->type = sym->type;

	if (flags & L_PUSH_VAL) {
		emit_load_scalar(tmp->idx);
		return (1);  // stack effect
	} else {
		return (0);  // stack effect
	}
}

/*
 * Compile obj->var.  Code to push the value of obj on the run-time
 * stack already has been generated by compile_idxOp().
 */
private int
compile_clsInstDeref(Expr *expr, Expr_f flags)
{
	int	in_class = 0;
	char	*clsnm, *varnm;
	Tmp	*tmp;
	Sym	*sym, *tmpsym;
	ClsDecl	*clsdecl = expr->a->type->u.class.clsdecl;
	Tcl_HashEntry *hPtr;

	ASSERT(isclass(expr->a) && clsdecl);
	ASSERT(clsdecl->symtab);

	clsnm = clsdecl->decl->id->str;
	varnm = expr->str;
	if (L->enclosing_func) {
		in_class = L->enclosing_func->decl->flags & DECL_CLASS_FN;
	}

	hPtr = Tcl_FindHashEntry(clsdecl->symtab, varnm);
	unless (hPtr) {
		L_errf(expr, "%s is not a member of class %s", varnm, clsnm);
		expr->type = L_poly;
		return (0); // stack effect
	}
	sym = (Sym *)Tcl_GetHashValue(hPtr);
	unless (in_class || (sym->decl->flags & DECL_PUBLIC)) {
		L_errf(expr, "%s is not a public variable of class %s",
		       varnm, clsnm);
	}
	unless (sym->decl->flags & DECL_CLASS_INST_VAR) {
		L_errf(expr, "%s is not an instance variable of class %s",
		       varnm, clsnm);
	}

	if (flags & L_PUSH_NAME) {
		// Caller already pushed obj value, so concat var name to it.
		push_litf("::%s", sym->name);
		TclEmitInstInt1(INST_STR_CONCAT1, 2, L->frame->envPtr);
		expr->sym  = sym;
		expr->type = sym->type;
		return (1);  // stack effect
	}

	tmp = tmp_get(TMP_UNSET);
	tmpsym = sym_mk(tmp->name, sym->type, SCOPE_LOCAL | DECL_LOCAL_VAR);
	ASSERT(tmpsym);  // cannot be multiply declared
	tmpsym->used_p = TRUE;

	push_lit(sym->name);
	TclEmitInstInt4(INST_NSUPVAR, tmp->idx, L->frame->envPtr);
	emit_pop();

	expr->sym  = tmpsym;
	expr->type = sym->type;

	if (flags & L_PUSH_VAL) {
		emit_load_scalar(tmp->idx);
		return (1);  // stack effect
	} else {
		return (0);  // stack effect
	}
}

private void
compile_assign(Expr *expr)
{
	Expr	*lhs = expr->a;
	Expr	*rhs = expr->b;

	if (lhs->op == L_OP_LIST) {
		/* Handle {a,b,c} = ... */
		compile_assignComposite(expr);
	} else {
		/* Handle regular assignment. */
		compile_expr(rhs, L_PUSH_VAL);
		compile_assignFromStack(lhs, rhs->type, expr, 0);
	}
}

private void
compile_assignFromStack(Expr *lhs, Type *rhs_type, Expr *expr, int flags)
{
	/* Whether it's an arithmetic assignment (lhs op= rhs). */
	int	arith = (expr && (expr->op != L_OP_EQUALS));

	compile_expr(lhs, (arith?L_PUSH_VALPTR:L_PUSH_PTR) | L_LVALUE | flags);
	unless (lhs->sym) {
		L_errf(lhs, "invalid l-value in assignment");
		return;
	}
	L_typeck_assign(lhs, rhs_type);

	if (isdeepdive(lhs)) {
		// <rval> <lhs-ptr>               if !arith
		// <rval> <lhs-val> <lhs-ptr>     if arith
		if (arith) {
			// <rval> <lhs-val> <lhs-ptr>
			TclEmitInstInt4(INST_REVERSE, 3, L->frame->envPtr);
			// <lhs-ptr> <lhs-val> <rval>
			emit_instrForLOp(expr, expr->type);
			// <lhs-ptr> <new-val>
			TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr);
		}
		// <rval> <lhs-ptr>   or   <new-val> <lhs-ptr>
		TclEmitInstInt4(INST_L_DEEP_WRITE,
				lhs->sym->idx,
				L->frame->envPtr);
		TclEmitInt4(L_PUSH_NEW, L->frame->envPtr);
	} else {
		// <rval>
		if (arith) {
			emit_load_scalar(lhs->sym->idx);
			// <rval> <old-val>
			TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr);
			// <old-val> <rval>
			emit_instrForLOp(expr, expr->type);
			// <new-val>
		}
		// <rval>   or   <new-val>
		emit_store_scalar(lhs->sym->idx);
	}
	// <rval>
}

private void
compile_assignComposite(Expr *expr)
{
	int	i;
	Expr	*lhs = expr->a;
	Expr	*rhs = expr->b;
	Type	*list = NULL, *rhs_elt_type;
	VarDecl	*member = NULL;

	expr->type = L_poly;
	unless (expr->op == L_OP_EQUALS) {
		L_errf(expr, "arithmetic assignment illegal");
		lhs->type = L_poly;
		rhs->type = L_poly;
		return;
	}
	ASSERT(lhs->op == L_OP_LIST);

	compile_expr(rhs, L_PUSH_VAL);

	/* rhs_elt_type stores the current rhs type as we walk the elts. */
	switch (rhs->type->kind) {
	    case L_POLY:
		rhs_elt_type = L_poly;
		break;
	    case L_ARRAY:
		rhs_elt_type = rhs->type->base_type;
		break;
	    case L_STRUCT:
		member = rhs->type->u.struc.members;
		ASSERT(member);
		rhs_elt_type = member->type;
		break;
	    case L_LIST:
		list = rhs->type;
		rhs_elt_type = list->base_type;
		break;
	    default:
		L_errf(expr,
		       "right-hand side incompatible with composite assign");
		return;
	}
	/* Assign lhs <- rhs elements (left to right). */
	for (i = 0, lhs = expr->a; lhs; ++i, lhs = lhs->b) {
		ASSERT(lhs->op == L_OP_LIST);
		/* A lhs undef means skip the corresponding rhs element. */
		unless (isid(lhs->a, "undef")) {
			TclEmitInstInt1(INST_L_LINDEX_STK, i, L->frame->envPtr);
			compile_assignFromStack(lhs->a, rhs_elt_type, expr, 0);
			emit_pop();
		}
		/* Advance rhs_elt_type to type of next elt, if known. */
		if (member) {
			member = member->next;
			rhs_elt_type = member? member->type: NULL;
		} else if (list) {
			list = list->next;
			rhs_elt_type = list? list->base_type: NULL;
		}
	}
	/* Pop rhs. */
	emit_pop();
	/* The value of the assignment is undef. */
	TclEmitOpcode(INST_L_PUSH_UNDEF, L->frame->envPtr);
}

private void
compile_incdec(Expr *expr)
{
	Expr	*lhs = expr->a;
	/* Whether expr is a postfix operator. */
	int	post = ((expr->op == L_OP_PLUSPLUS_POST) ||
			(expr->op == L_OP_MINUSMINUS_POST));
	/* Whether expr is a ++ operator. */
	int	inc = ((expr->op == L_OP_PLUSPLUS_PRE) ||
		       (expr->op == L_OP_PLUSPLUS_POST));

	compile_expr(lhs, L_PUSH_PTRVAL | (post?L_PUSH_VAL:0) | L_LVALUE);
	unless (lhs->sym) {
		L_errf(expr, "invalid l-value in inc/dec");
		return;
	}
	L_typeck_expect(L_INT|L_FLOAT, lhs, "in ++/--");

	if (isdeepdive(lhs)) {
		// <lhs-ptr> <lhs-val>
		push_lit("1");
		// <hs-ptr> <lhs-val> 1
		TclEmitOpcode(inc?INST_ADD:INST_SUB, L->frame->envPtr);
		// <lhs-ptr> <new-val>
		TclEmitInstInt1(INST_ROT, 1, L->frame->envPtr);
		// <new-val> <lhs-ptr>
		TclEmitInstInt4(INST_L_DEEP_WRITE,
				lhs->sym->idx,
				L->frame->envPtr);
		TclEmitInt4(post?L_PUSH_OLD:L_PUSH_NEW, L->frame->envPtr);
	} else {
		// <old-val>   if post
		TclEmitInstInt1(INST_INCR_SCALAR1_IMM, lhs->sym->idx,
				L->frame->envPtr);
		TclEmitInt1(inc? 1 : -1, L->frame->envPtr);
		// <old-val> <new-val>   if post
		// <new-val>             if !post
		if (post) emit_pop();
	}
	// <old-val>   if post
	// <new-val>   if !post
}

private int
push_regexpModifiers(Expr *regexp)
{
	int	n = 0;

	push_lit("-linestop");
	n++;
	if (regexp->flags & L_EXPR_RE_I) {
		push_lit("-nocase");
		n++;
	}
	if (regexp->flags & L_EXPR_RE_G) {
		push_lit("-all");
		n++;
	}
	return (n);
}

private void
emit_instrForLOp(Expr *expr, Type *type)
{
	int	arg = 0;
	int	op  = 0;

	switch (expr->op) {
	    case L_OP_EQUALEQUAL:
	    case L_OP_NOTEQUAL:
	    case L_OP_GREATER:
	    case L_OP_GREATEREQ:
	    case L_OP_LESSTHAN:
	    case L_OP_LESSTHANEQ:
		switch (type->kind) {
		    case L_INT:
		    case L_FLOAT:
		    case L_POLY:
			switch (expr->op) {
			    case L_OP_EQUALEQUAL:
				op = INST_EQ;
				break;
			    case L_OP_NOTEQUAL:
				op = INST_NEQ;
				break;
			    case L_OP_GREATER:
				op = INST_GT;
				break;
			    case L_OP_GREATEREQ:
				op = INST_GE;
				break;
			    case L_OP_LESSTHAN:
				op = INST_LT;
				break;
			    case L_OP_LESSTHANEQ:
				op = INST_LE;
				break;
			    default: ASSERT(0);
			}
			break;
		    case L_STRING:
		    case L_WIDGET:
			switch (expr->op) {
			    case L_OP_EQUALEQUAL:
				op = INST_STR_EQ;
				break;
			    case L_OP_NOTEQUAL:
				op = INST_STR_NEQ;
				break;
			    default:
				TclEmitOpcode(INST_STR_CMP, L->frame->envPtr);
				switch (expr->op) {
				    case L_OP_GREATER:
					push_lit("1");
					op = INST_EQ;
					break;
				    case L_OP_LESSTHAN:
					push_lit("-1");
					op = INST_EQ;
					break;
				    case L_OP_GREATEREQ:
					push_lit("0");
					op = INST_GE;
					break;
				    case L_OP_LESSTHANEQ:
					push_lit("0");
					op = INST_LE;
					break;
				    default: ASSERT(0);
				}
				break;
			}
			break;
		    default:
			// We get here only for eq() of a composite type
			// w/no numerics.
			op = INST_STR_EQ;
			break;
		}
		break;
	    case L_OP_STR_EQ:
		op = INST_STR_EQ;
		break;
	    case L_OP_STR_NE:
		op = INST_STR_NEQ;
		break;
	    case L_OP_STR_GT:
	    case L_OP_STR_GE:
	    case L_OP_STR_LT:
	    case L_OP_STR_LE:
		TclEmitOpcode(INST_STR_CMP, L->frame->envPtr);
		switch (expr->op) {
		    case L_OP_STR_GT:
			push_lit("1");
			op = INST_EQ;
			break;
		    case L_OP_STR_LT:
			push_lit("-1");
			op = INST_EQ;
			break;
		    case L_OP_STR_GE:
			push_lit("0");
			op = INST_GE;
			break;
		    case L_OP_STR_LE:
			push_lit("0");
			op = INST_LE;
			break;
		    default: ASSERT(0);
		}
		break;
	    case L_OP_PLUS:
	    case L_OP_EQPLUS:
		op = INST_ADD;
		break;
	    case L_OP_MINUS:
	    case L_OP_EQMINUS:
		op = INST_SUB;
		break;
	    case L_OP_STAR:
	    case L_OP_EQSTAR:
		op = INST_MULT;
		break;
	    case L_OP_SLASH:
	    case L_OP_EQSLASH:
		op = INST_DIV;
		break;
	    case L_OP_PERC:
	    case L_OP_EQPERC:
		op = INST_MOD;
		break;
	    case L_OP_BITAND:
	    case L_OP_EQBITAND:
		op = INST_BITAND;
		break;
	    case L_OP_BITOR:
	    case L_OP_EQBITOR:
		op = INST_BITOR;
		break;
	    case L_OP_BITXOR:
	    case L_OP_EQBITXOR:
		op = INST_BITXOR;
		break;
	    case L_OP_LSHIFT:
	    case L_OP_EQLSHIFT:
		op = INST_LSHIFT;
		break;
	    case L_OP_RSHIFT:
	    case L_OP_EQRSHIFT:
		op = INST_RSHIFT;
		break;
	    case L_OP_UMINUS:
		op = INST_UMINUS;
		break;
	    case L_OP_UPLUS:
		op = INST_UPLUS;
		break;
	    case L_OP_BANG:
		op = INST_LNOT;
		break;
	    case L_OP_BITNOT:
		op = INST_BITNOT;
		break;
	    default:
		break;
	}
	if (op) {
		TclEmitOpcode(op, L->frame->envPtr);
		return;
	}
	switch (expr->op) {
	    case L_OP_EQDOT:
		op  = INST_STR_CONCAT1;
		arg = 2;
		break;
	    default:
		L_bomb("Unable to map operator %d to an instruction", expr->op);
		break;
	}
	if (op) {
		TclEmitInstInt1(op, arg, L->frame->envPtr);
	}
}

private void
compile_continue(Stmt *stmt)
{
	Frame	*loop_frame = frame_find(LOOP);

	unless (loop_frame) {
		L_errf(stmt, "continue allowed only inside loops");
		return;
	}
	loop_frame->continue_jumps = emit_jmp_fwd(INST_JUMP4,
						  loop_frame->continue_jumps);
}

private void
compile_break(Stmt *stmt)
{
	Frame	*loop_frame = frame_find(LOOP|SWITCH);

	unless (loop_frame) {
		L_errf(stmt,
		       "break allowed only inside switch and loop statements");
		return;
	}
	loop_frame->break_jumps = emit_jmp_fwd(INST_JUMP4,
					       loop_frame->break_jumps);
}

private void
compile_label(Stmt *stmt)
{
	Label	*label;

	if (!strcmp(stmt->u.label, "break")) {
		L_errf(stmt, "break is not a legal label");
	}
	label = label_lookup(stmt, LABEL_DEF);
	fixup_jmps(&label->fixups);
	label->fixups = NULL;
	label->offset = currOffset(L->frame->envPtr);
}

private void
compile_goto(Stmt *stmt)
{
	Label	*label;

	label = label_lookup(stmt, LABEL_USE);
	if (label->offset >= 0) {
		emit_jmp_back(TCL_UNCONDITIONAL_JUMP, label->offset);
	} else {
		label->fixups = emit_jmp_fwd(INST_JUMP4, label->fixups);
	}
}

private Label *
label_lookup(Stmt *stmt, Label_f flags)
{
	int		new;
	char		*name = stmt->u.label;
	Label		*label = NULL;
	Frame		*frame;
	Tcl_HashEntry	*hPtr = NULL;

	/* Labels are restricted to the enclosing proc's labeltab. */
	frame = frame_find(FUNC);
	ASSERT(frame);

	hPtr = Tcl_FindHashEntry(frame->labeltab, name);
	if (hPtr) {
		label = (Label *)Tcl_GetHashValue(hPtr);
	} else {
		label = (Label *)ckalloc(sizeof(Label));
		memset(label, 0, sizeof(Label));
		label->name   = name;
		label->offset = -1;
		hPtr = Tcl_CreateHashEntry(frame->labeltab, name, &new);
		ASSERT(new);
		Tcl_SetHashValue(hPtr, label);
	}
	if ((flags & LABEL_DEF) && (label->offset >= 0)) {
		L_errf(stmt, "label %s already defined", name);
	}
	return (label);
}

private void
emit_globalUpvar(Sym *sym)
{
	VarDecl	*decl = sym->decl;
	char	*id = sym->name;

	/*
	 * Tim comment: We attempt to detect whether L global
	 * variables should be true globals, or should be shared with
	 * the calling proc, by checking if the current variable frame
	 * pointer in interp is the same as the global frame pointer.
	 * (Sharing variables with the calling proc is useful if you
	 * want to use L as an expr replacement).
	 */
	if (((Interp *)L->interp)->rootFramePtr !=
	    ((Interp *)L->interp)->varFramePtr) {
		ASSERT(!(decl->flags & (DECL_CLASS_VAR | DECL_CLASS_INST_VAR)));
		frame_resumePrologue();
		push_lit("#0");
		push_lit(id);
		TclEmitInstInt4(INST_UPVAR, sym->idx, L->frame->envPtr);
		emit_pop();
		frame_resumeBody();
		return;
	}

	/*
	 * The namespace of the var we're creating an upvar alias to is
	 * either ::, an L class namespace, or an L class instance namespace
	 * where the local "self" holds the namespace name.
	 */
	frame_resumePrologue();
	switch (decl->flags &
		(DECL_GLOBAL_VAR | DECL_CLASS_VAR | DECL_CLASS_INST_VAR)) {
	    case DECL_GLOBAL_VAR:
		push_lit("::");
		/* Private globals get mangled to avoid clashes. */
		if (decl->flags & DECL_PRIVATE) {
			push_litf("_%s_%s", L->toplev, id);
		} else {
			push_lit(id);
		}
		break;
	    case DECL_CLASS_VAR:
		push_litf("::L::_class_%s", decl->clsdecl->decl->id->str);
		push_lit(id);
		break;
	    case DECL_CLASS_INST_VAR: {
		Sym *self = sym_lookup(mkId("self"), L_NOWARN);
		ASSERT(self);
		emit_load_scalar(self->idx);
		push_lit(id);
		break;
	    }
	}
	TclEmitInstInt4(INST_NSUPVAR, sym->idx, L->frame->envPtr);
	emit_pop();
	frame_resumeBody();
}

/*
 * Add a variable or function name to the symbol table.  If it's a
 * local variable, allocate a slot for it in the current proc.
 *
 * Print an error if the symbol is already defined.  The rules are
 *
 * - Multiply defined globals are illegal, with the exception that
 *   main() can be re-defined.
 * - A local cannot shadow any other local in the proc.
 * - A local can shadow a global.
 * - A local can shadow a global upvar shadow (which is a local
 *   with special status).
 *
 * Scopes are created as follows.  The complexity stems from Tcl
 * requiring local upvar shadows as the only way to access globals.
 * So we have a scope in which the global symbol is stored and a
 * nested scope for the proc in which the local upvar shadow is
 * stored.
 *
 * There is one scope hierarchy per Tcl Interp in which L code
 * appears, as illustrated next.  OUTER,SCRIPT,TOPLEV,SKIP etc are frame
 * flags (Frame_f); SKIP means that the scope is skipped when
 * searching enclosing scopes.
 *
 * [ outer-most scope (OUTER): public globals go in this frame's symtab
 *     [ file scope (SCRIPT): private globals go in this frame's symtab
 *         [ * (%%n_toplevel proc) (TOPLEV|SKIP)
 *             global initializers get compiled in this scope, causing the
 *             local upvar shadows to go in this scope's symtab
 *             [ class outer-most (CLS_OUTER): class/instance vars & private
 *                 member fns go in this frame's symtab
 *                 [ * class top-level (CLS_TOPLEV|SKIP)
 *                     class variable initializers get compiled in this scope
 *                     (note that this is still in the %%n_toplevel proc)
 *                     [ (constructor proc)
 *                         instance var initializers get compiled here
 *                     ]
 *                     [ (destructor proc)
 *                     ]
 *                     [ (member fn proc): public fn names go in outer-most
 *                         scope's, symtable, private fn names go in class
 *                         outer-most scope, fn locals go in this frame's
 *                         symtab
 *                         [ block
 *                             [ nested blocks...
 *                             ]
 *                         ]
 *                     ]
 *                 ]
 *             ]
 *             [ regular function (proc): public fn name goes in outer-most
 *               scope's symtab, private fn name goes in file scope's symtab,
 *               fn locals go in this frame's symtab
 *                 [ block
 *                     [ nested blocks...
 *                     ]
 *                 ]
 *             ]
 *         ]
 *     ]
 * ]
 */
private Sym *
sym_store(VarDecl *decl)
{
	int	new;
	char	*name = decl->id->str;
	Sym	*sym = NULL;
	Sym	*sym2;
	Frame	*frame = NULL;
	Tcl_HashEntry *hPtr;

	/* Check for multiple declaration. */
	switch (decl->flags &
		(SCOPE_LOCAL | SCOPE_GLOBAL | SCOPE_SCRIPT | SCOPE_CLASS)) {
	    case SCOPE_GLOBAL:
	    case SCOPE_SCRIPT:
		/* Declaring a global -- search outer-most and file frames. */
		frame = frame_find(OUTER);
		hPtr = Tcl_FindHashEntry(frame->symtab, name);
		unless (hPtr) {
			frame = frame_find(SCRIPT);
			hPtr = Tcl_FindHashEntry(frame->symtab, name);
		}
		if (hPtr) {
			sym2 = (Sym *)Tcl_GetHashValue(hPtr);
			if (decl->flags & DECL_EXTERN) {
				sym = (Sym *)Tcl_GetHashValue(hPtr);
				if (L_typeck_same(decl->type, sym->type)) {
					return (sym);
				}
				L_errf(decl,
				       "extern re-declaration type does not "
				       "match other declaration");
				return (NULL);
			} else if (sym2->decl->flags & DECL_ERR) {
				Tcl_DeleteHashEntry(hPtr);
			} else {
				L_errf(decl,
				    "multiple declaration of global %s", name);
				return (NULL);
			}
		}
		break;
	    case SCOPE_CLASS:
		/* Declaring class var -- search up thru class outer scope. */
		for (frame = L->frame; frame; frame = frame->prevFrame) {
			hPtr = Tcl_FindHashEntry(frame->symtab, name);
			if (hPtr) {
				sym2 = (Sym *)Tcl_GetHashValue(hPtr);
				if (sym2->decl->flags & DECL_ERR) {
					Tcl_DeleteHashEntry(hPtr);
				} else {
					L_errf(decl, "multiple declaration of %s",
					       name);
					return (NULL);
				}
			}
			if (frame->flags & CLS_OUTER) break;
		}
		break;
	    case SCOPE_LOCAL:
		/*
		 * Declaring a local -- search current proc's local
		 * scopes, then the global scope so we can issue a warning
		 * if this is a local that shadows a class or global var.
		 */
		for (frame = L->frame; frame; frame = frame->prevFrame) {
			unless (frame->envPtr == L->frame->envPtr) break;
			hPtr = Tcl_FindHashEntry(frame->symtab, name);
			if (hPtr) {
				sym = (Sym *)Tcl_GetHashValue(hPtr);
				ASSERT(sym->kind & L_SYM_LVAR);
				unless (sym->kind & L_SYM_LSHADOW) {
					L_errf(decl, "multiple declaration "
					       "of local %s", name);
					return (NULL);
				}
			}
		}
		for (; frame; frame = frame->prevFrame) {
			hPtr = Tcl_FindHashEntry(frame->symtab, name);
			unless (hPtr && (frame->flags & SEARCH)) continue;
			sym2 = (Sym *)Tcl_GetHashValue(hPtr);
			if (sym2->decl->flags & DECL_GLOBAL_VAR) {
				L_warnf(decl, "local variable %s shadows "
					"a global declared at %s:%d",
					name, sym2->decl->node.loc.file,
					sym2->decl->node.loc.line);
			} else if (sym2->decl->flags & DECL_CLASS_VAR) {
				L_warnf(decl, "local variable %s shadows "
					"a class variable declared at %s:%d",
					name, sym2->decl->node.loc.file,
					sym2->decl->node.loc.line);
			} else if (sym2->decl->flags & DECL_CLASS_INST_VAR) {
				L_warnf(decl, "local variable %s shadows a "
					"class instance variable declared "
					"at %s:%d", name,
					sym2->decl->node.loc.file,
					sym2->decl->node.loc.line);
			}
		}
		break;
	    default:
		ASSERT(0);
		break;
	}

	/* Select the frame to add the symbol to. */
	switch (decl->flags &
		(SCOPE_LOCAL | SCOPE_GLOBAL | SCOPE_SCRIPT | SCOPE_CLASS)) {
	    case SCOPE_GLOBAL:
		frame = frame_find(OUTER);
		break;
	    case SCOPE_SCRIPT:
		frame = frame_find(SCRIPT);
		break;
	    case SCOPE_CLASS:
		frame = frame_find(CLS_OUTER);
		break;
	    case SCOPE_LOCAL:
		frame = L->frame;
		break;
	    default:
		ASSERT(0);
		break;
	}
	hPtr = Tcl_CreateHashEntry(frame->symtab, name, &new);
	/* If it's not new, it must be shadowing a global. */
	ASSERT(new || (sym && (sym->kind & L_SYM_LSHADOW) &&
		       (decl->flags & (DECL_LOCAL_VAR | DECL_CLASS_INST_VAR))));
	sym = (Sym *)ckalloc(sizeof(Sym));
	memset(sym, 0, sizeof(*sym));
	sym->name = ckstrdup(name);
	sym->type = decl->type;
	sym->decl = decl;

	/*
	 * Set the name of the tcl variable, mangling it to avoid
	 * clashes.
	 */
	if (isfntype(decl->type)) {
		ASSERT(decl->flags & (DECL_FN | DECL_CLASS_FN));
		sym->kind = L_SYM_FN;
		if (decl->tclprefix) {
			sym->tclname = cksprintf("%s%s", decl->tclprefix, name);
		} else {
			sym->tclname = ckstrdup(name);
		}
	} else if (decl->flags & DECL_GLOBAL_VAR) {
		sym->kind    = L_SYM_GVAR;
		sym->tclname = cksprintf("_%s", name);
	} else if (decl->flags & (DECL_CLASS_VAR | DECL_CLASS_INST_VAR)) {
		sym->kind    = L_SYM_GVAR;
		sym->tclname = cksprintf("_%s_%s",
					 decl->clsdecl->decl->id->str,
					 name);
	} else {
		ASSERT(decl->flags & DECL_LOCAL_VAR);
		sym->kind    = L_SYM_LVAR;
		sym->tclname = ckstrdup(name);
	}

	/* If a local, allocate a slot for it. */
	if (sym->kind & L_SYM_LVAR) {
		sym->idx = TclFindCompiledLocal(name, strlen(name),
						1, L->frame->envPtr);
	} else {
		sym->idx = -1;
	}

	decl->id->sym  = sym;
	decl->id->type = decl->type;
	Tcl_SetHashValue(hPtr, sym);

	return (sym);
}

/*
 * Lookup id in the symbol table.
 *
 * flags & L_NOTUSED ==> don't mark the id as having been referenced
 * (used for warning which variables are unused).
 *
 * flags & L_NOWARN ==> don't print error message if id not found.
 *
 * The first time a global is referenced within a scope, an upvar is
 * created for it.
 */
private Sym *
sym_lookup(Expr *id, Expr_f flags)
{
	int	new;
	char	*name;
	Sym	*shw;
	Sym	*sym = NULL;
	Frame	*frame;
	Tcl_HashEntry *hPtr = NULL;

	unless (id->kind == L_EXPR_ID) return (NULL);
	name = id->str;

	for (frame = L->frame; frame; frame = frame->prevFrame) {
		if ((frame->envPtr == L->frame->envPtr) ||
		    (frame->flags & SEARCH)) {
			hPtr = Tcl_FindHashEntry(frame->symtab, name);
			if (hPtr) break;
		}
	}
	if (hPtr) sym = (Sym *)Tcl_GetHashValue(hPtr);
	if (sym) {
		/*
		 * If a global is being referenced for the first time
		 * in this scope, create a local upvar to shadow it
		 * in the symtab of the enclosing proc or top-level.
		 */
		if ((sym->kind & L_SYM_GVAR) && (sym->idx == -1)) {
			Frame	*proc_frame;
			// assert global => in outer-most or file frame
			ASSERT(!(sym->decl->flags & DECL_GLOBAL_VAR) ||
			       (frame->flags & (OUTER|SCRIPT)));
			// assert class var => in class outer-most frame
			ASSERT(!(sym->decl->flags & DECL_CLASS_VAR) ||
			       (frame->flags & CLS_OUTER));
			// assert class instance var => class outer-most frame
			ASSERT(!(sym->decl->flags & DECL_CLASS_INST_VAR) ||
			       (frame->flags & CLS_OUTER));
			proc_frame = frame_find(TOPLEV|CLS_TOPLEV|FUNC);
			ASSERT(proc_frame);
			hPtr = Tcl_CreateHashEntry(proc_frame->symtab, name,
						   &new);
			ASSERT(new);
			shw = (Sym *)ckalloc(sizeof(Sym));
			memset(shw, 0, sizeof(*shw));
			shw->kind    = L_SYM_LVAR | L_SYM_LSHADOW;
			shw->name    = ckstrdup(name);
			shw->tclname = ckstrdup(sym->tclname);
			shw->type    = sym->decl->type;
			shw->decl    = sym->decl;
			shw->used_p  = TRUE;
			shw->idx     = TclFindCompiledLocal(shw->tclname,
						strlen(shw->tclname),
						1,
						L->frame->envPtr);
			emit_globalUpvar(shw);
			Tcl_SetHashValue(hPtr, shw);
			sym = shw;
		}
		unless (flags & L_NOTUSED) sym->used_p = TRUE;
		id->sym  = sym;
		id->type = sym->type;
		return (sym);
	} else {
		ASSERT(id->sym == NULL);
		unless (flags & L_NOWARN) {
			/*
			 * Add the undeclared variable to the symtab to avoid
			 * cascading errors.
			 */
			YYLTYPE	loc = id->node.loc;
			VarDecl	*decl = ast_mkVarDecl(L_poly, id, loc, loc);
			decl->flags = DECL_ERR | DECL_ARGUSED;
			switch (L->frame->flags & (FUNC|CLS_TOPLEV|TOPLEV)) {
			    case TOPLEV | FUNC:
				decl->flags |= SCOPE_GLOBAL | DECL_GLOBAL_VAR;
				break;
			    case CLS_TOPLEV:
				decl->flags |= SCOPE_CLASS | DECL_CLASS_VAR;
				ASSERT(L->frame->clsdecl);
				decl->clsdecl = L->frame->clsdecl;
				break;
			    case FUNC:
			    case 0:  // stmt block
				decl->flags |= SCOPE_LOCAL | DECL_LOCAL_VAR;
				break;
			    default: ASSERT(0);
			}
			L_errf(id, "undeclared variable: %s", name);
			id->sym = sym_store(decl);
		}
		id->type = L_poly;
		return (NULL);
	}
}

private Sym *
sym_mk(char *name, Type *t, Decl_f flags)
{
	YYLTYPE	loc = { 0 };
	Expr	*id = mkId(name);
	VarDecl	*decl = ast_mkVarDecl(t, id, loc, loc);

	decl->flags = flags;
	return (sym_store(decl));
}

private Tmp *
tmp_get(TmpKind kind)
{
	Tmp	*tmp;

	for (tmp = L->frame->tmps; tmp; tmp = tmp->next) {
		if (tmp->free) break;
	}
	unless (tmp) {
		tmp = (Tmp *)ckalloc(sizeof(*tmp));
		tmp->next = L->frame->tmps;
		L->frame->tmps = tmp;
		tmp->name = cksprintf("=temp%d", L->tmpnum++);
		tmp->idx  = TclFindCompiledLocal(tmp->name, strlen(tmp->name),
						 1, L->frame->envPtr);
	}
	tmp->free = 0;
	/*
	 * Sometimes we need a tmp var that is not set to anything.
	 * For example, to create an upvar or to use the INST_DICT_*
	 * bytecodes.
	 */
	if (kind == TMP_UNSET) {
		TclEmitInstInt4(INST_UNSET_LOCAL, tmp->idx, L->frame->envPtr);
	}
	return (tmp);
}

private void
tmp_free(Tmp *tmp)
{
	if (tmp) tmp->free = 1;
}

private void
tmp_freeAll(Tmp *tmp)
{
	while (tmp) {
		Tmp *next = tmp->next;
		ckfree((char *)tmp);
		tmp = next;
	}
}

void
L_bomb(const char *format, ...)
{
	va_list	ap;

	va_start(ap, format);
	fprintf(stderr, "L Internal Error: ");
	vfprintf(stderr, format, ap);
	va_end(ap);
	fprintf(stderr, "\n");
	exit(1);
}

/*
 * L_synerr is Bison's yyerror and is called by the parser for syntax
 * errors.  Bail out by longjumping back to Tcl_LObjCmd, as a way
 * to work-around a possible compiler bug in our Windows build where
 * the Bison-generated parser's own internal longjmp causes a crash.
 */
void
L_synerr(const char *s)
{
	int	i, off;
	char	*beg = Tcl_GetString(L->script);
	char	*end = beg + L->script_len;
	char	*line, *stop;

	unless (L->errs) {
		L->errs = Tcl_NewObj();
		L->err  = 1;
	}
	Tcl_AppendPrintfToObj(L->errs, "%s:%d: L Error: %s\n",
			      L->file, L->line, s);

	/* Search backwards to find the start of the offending line. */
	off = L_lloc.beg;
	ASSERT(off >= 0);
	ASSERT(beg);
	for (line = beg+off; (line > beg) && (line[-1] != '\n'); --line) ;
	off = beg+off - line;  // is now offset from start of offending line

	/* Print the offending line with a ^ pointing to the current token. */
	stop = line + off;
	for (i = 1; (*line != '\n') && (line < end); ++i) {
		// adjust for tab printing >1 char
		if ((*line == '\t') && (line <= stop)) {
			off += 8 - i%8;
			i += 7;
		}
		Tcl_AppendToObj(L->errs, line++, 1);
	}
	Tcl_AppendToObj(L->errs, "\n", 1);
	ASSERT(off >= 0);
	while (off--) Tcl_AppendToObj(L->errs, " ", 1);
	Tcl_AppendToObj(L->errs, "^\n", 2);

	longjmp(L->jmp, 0);
}

/*
 * Like L_synerr() above but take the offset of the offending token
 * instead of using the current token.
 */
void
L_synerr2(const char *s, int offset)
{
	L_lloc.beg = offset;
	L_synerr(s);
}

void
L_warnf(void *node, const char *format, ...)
{
	va_list ap;
	int	len = 64;
	char	*buf, *fmt;

	if (hash_get(L->options, "nowarn")) return;

	fmt = cksprintf("%s:%d: L Warning: %s\n",
			((Ast *)node)->loc.file, ((Ast *)node)->loc.line,
			format);
	va_start(ap, format);
	while (!(buf = ckvsprintf(fmt, ap, len))) {
		va_end(ap);
		va_start(ap, format);
		len *= 2;
	}
	va_end(ap);
	unless (L->errs) {
		L->errs = Tcl_NewObj();
		L->err  = 1;
	}
	Tcl_AppendToObj(L->errs, buf, -1);
	ckfree(fmt);
	ckfree(buf);
}

void
L_err(const char *format, ...)
{
	va_list ap;
	int	len = 64;
	char	*buf, *fmt;

	fmt = cksprintf("%s:%d: L Error: %s\n", L->file, L->line, format);
	va_start(ap, format);
	while (!(buf = ckvsprintf(fmt, ap, len))) {
		va_end(ap);
		va_start(ap, format);
		len *= 2;
	}
	va_end(ap);
	unless (L->errs) {
		L->errs = Tcl_NewObj();
		L->err  = 1;
	}
	Tcl_AppendToObj(L->errs, buf, -1);
	ckfree(fmt);
	ckfree(buf);
}

void
L_errf(void *node, const char *format, ...)
{
	va_list ap;
	int	len = 64;
	char	*buf, *fmt;

	if (node) {
		fmt = cksprintf("%s:%d: L Error: %s\n",
				((Ast *)node)->loc.file,
				((Ast *)node)->loc.line,
				format);
	} else {
		fmt = cksprintf("L Error: %s\n", format);
	}
	va_start(ap, format);
	while (!(buf = ckvsprintf(fmt, ap, len))) {
		va_end(ap);
		va_start(ap, format);
		len *= 2;
	}
	va_end(ap);
	unless (L->errs) {
		L->errs = Tcl_NewObj();
		L->err  = 1;
	}
	Tcl_AppendToObj(L->errs, buf, -1);
	ckfree(fmt);
}

private void
ast_free(Ast *ast_list)
{
	while (ast_list) {
		Ast	*node = ast_list;
		ast_list = ast_list->next;
		switch (node->type) {
		    case L_NODE_STMT: {
			Stmt *s = (Stmt *)node;
			if ((s->kind == L_STMT_LABEL) ||
			    (s->kind == L_STMT_GOTO)) {
				ckfree(s->u.label);
			}
			break;
		    }
		    case L_NODE_EXPR:
			ckfree(((Expr *)node)->str);
			break;
		    case L_NODE_VAR_DECL:
			ckfree(((VarDecl *)node)->tclprefix);
			break;
		    default:
			break;
		}
		ckfree((char *)node);
	}
}

private void
type_free(Type *type_list)
{
	while (type_list) {
		Type	*type = type_list;
		type_list = type_list->list;
		if (type->kind == L_STRUCT) ckfree(type->u.struc.tag);
		ckfree(type->name);
		ckfree((char *)type);
	}
}

/*
 * This is basically a whacked version of EnterCmdStartData and
 * EnterCmdWordData from tclCompile.c.
 */
private void
track_cmd(int codeOffset, void *node)
{
	int	cmdIndex = L->frame->envPtr->numCommands++;
	Ast	*ast = (Ast *)node;
	int	len = ast->loc.end - ast->loc.beg;
	int	srcOffset = ast->loc.beg;
	ECL	*ePtr;
	CmdLocation *cmdLocPtr;
	CompileEnv *envPtr = L->frame->envPtr;
	ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr;

	if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
		Tcl_Panic("track_cmd: bad command index %d", cmdIndex);
	}
	if (cmdIndex >= envPtr->cmdMapEnd) {
		/*
		 * Expand the command location array by allocating
		 * more storage from the heap. The currently allocated
		 * CmdLocation entries are stored from cmdMapPtr[0] up
		 * to cmdMapPtr[envPtr->cmdMapEnd] (inclusive).
		 */
		size_t currElems = envPtr->cmdMapEnd;
		size_t newElems  = 2*currElems;
		size_t currBytes = currElems * sizeof(CmdLocation);
		size_t newBytes  = newElems * sizeof(CmdLocation);
		CmdLocation *newPtr = (CmdLocation *)ckalloc((int)newBytes);

		/*
		 * Copy from old command location array to new, free
		 * old command location array if needed, and mark new
		 * array as malloced.
		 */
		memcpy(newPtr, envPtr->cmdMapPtr, currBytes);
		if (envPtr->mallocedCmdMap) ckfree((char *)envPtr->cmdMapPtr);
		envPtr->cmdMapPtr      = (CmdLocation *)newPtr;
		envPtr->cmdMapEnd      = newElems;
		envPtr->mallocedCmdMap = 1;
	}

	cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
	cmdLocPtr->codeOffset   = codeOffset;
	cmdLocPtr->srcOffset    = srcOffset;
	cmdLocPtr->numSrcBytes  = len;
	cmdLocPtr->numCodeBytes = currOffset(envPtr) - codeOffset;

	/*
	 * The command locations have to be sorted in ascending order
	 * by codeOffset.  (Or Tcl panics in GetCmdLocEncodingSize(),
	 * if nothing else). However, when L compiles nested function
	 * calls, the outer one will get tracked second, even though
	 * it begins first.  So we walk the new CmdLocation entry back
	 * from the end until it lands where it belongs.
	 */
	while ((cmdIndex > 0) && (envPtr->cmdMapPtr[cmdIndex-1].codeOffset >
				  envPtr->cmdMapPtr[cmdIndex].codeOffset)) {
		CmdLocation cmdLoc = envPtr->cmdMapPtr[cmdIndex];
		envPtr->cmdMapPtr[cmdIndex]   = envPtr->cmdMapPtr[cmdIndex-1];
		envPtr->cmdMapPtr[cmdIndex-1] = cmdLoc;
		cmdIndex--;
	}

	if (eclPtr->nuloc >= eclPtr->nloc) {
		/*
		 * Expand the ECL array by allocating more storage
		 * from the heap. The currently allocated ECL entries
		 * are stored from eclPtr->loc[0] up to
		 * eclPtr->loc[eclPtr->nuloc-1] (inclusive).
		 */
		size_t currElems = eclPtr->nloc;
		size_t newElems = (currElems ? 2*currElems : 1);
		size_t newBytes = newElems * sizeof(ECL);
		eclPtr->loc = (ECL *) ckrealloc((char *) eclPtr->loc, newBytes);
		eclPtr->nloc = newElems;
	}

	/* We enter only one word for the L command. */
	ePtr = &eclPtr->loc[eclPtr->nuloc];
	ePtr->srcOffset = srcOffset;
	ePtr->line = (int *) ckalloc(sizeof(int));
	ePtr->nline = 1;
	eclPtr->nuloc ++;
}

/*
 * API for tracking when we are compiling a function argument. This is
 * used to check whether an (expand) operator is being used as a
 * function argument (OK) or as something else (error).
 *
 * fnCallBegin:		call just before compiling a fn call
 * fnCallEnd:		call just after compiling a fn call
 * fnInArgList:		returns 1 if we are just starting to compile a
 *			fn call arg; returns 0 if we're either outside of a
 *			fn call or nested within an expression inside of
 *			an arg:
 *			    foo(x)     -- true
 *			    foo(x+y)   -- false
 */
private int
fnCallBegin()
{
	int old = L->call_level;
	L->call_level = L->expr_level;
	return (old);
}
private void
fnCallEnd(int lev)
{
	L->call_level = lev;
}
private int
fnInArgList()
{
	return (L->expr_level == (L->call_level + 1));
}

private Expr *
mkId(char *name)
{
	YYLTYPE	loc = { 0 };

	return (ast_mkId(name, loc, loc));
}

char *
ckstrdup(const char *str)
{
	if (str) {
		return (ckstrndup(str, strlen(str)));
	} else {
		return (NULL);
	}
}

char *
ckstrndup(const char *str, int len)
{
	char	*newStr = ckalloc(len+1);

	strncpy(newStr, str, len);
	newStr[len] = '\0';
	return (newStr);
}

char *
cksprintf(const char *fmt, ...)
{
	va_list	ap;
	int	len = 64;
	char	*buf;

	va_start(ap, fmt);
	while (!(buf = ckvsprintf(fmt, ap, len))) {
		va_end(ap);
		va_start(ap, fmt);
		len *= 2;
	}
	va_end(ap);
	return (buf);
}

/*
 * Allocate a buffer of len bytes and attempt a vsnprintf and fail
 * (return NULL) if len isn't enough.  The caller should double len
 * and re-try.  We require the caller to re-try instead of re-trying
 * here because on some platforms "ap" is changed by the vsnprintf
 * call and there is no portable way to save and restore it.
 */
char *
ckvsprintf(const char *fmt, va_list ap, int len)
{
	char	*buf = ckalloc(len);
	int	ret  = vsnprintf(buf, len, fmt, ap);
	/*
	 * The meaning of the return value depends on the platform.
	 * Some return the needed length (minus 1), some return -1,
	 * some truncate the buffer.  For the latter, ret will be
	 * len-1 and we won't know whether it barely fit or wasn't
	 * enough, so just fail on that case.
	 */
	if ((ret >= (len-1)) || (ret < 0)) {
		ckfree(buf);
		return (NULL);
	}
	return (buf);
}

/*
 * Since we have C-like variable declarations in L, when hashes and
 * arrays are declared, the base type is parsed separately from the
 * array sizes or hash-element types.  The next two functions put them
 * back together.  E.g., in
 *
 *    string h{int};
 *
 * the main type passed in to these functions is a hash type
 * (w/index type of "int") but the hash type doesn't yet have its
 * base type set, which in this example is "string".
 *
 * For simple declarations (like "string s") where there is no
 * explicit array or hash, decl->type won't be set by the parser, so
 * the base type goes there.  For arrays/hashes, decl->type points to
 * the first level of array or hash, and the base type must go onto
 * the last nested hash or array type.
 */

void
L_set_baseType(Type *type, Type *base_type)
{
	while (type->base_type) {
		ASSERT((type->kind == L_ARRAY) ||
		       (type->kind == L_HASH) ||
		       (type->kind == L_NAMEOF));
		type = type->base_type;
	}
	type->base_type = base_type;
}

void
L_set_declBaseType(VarDecl *decl, Type *base_type)
{
	if (decl->type) {
		L_set_baseType(decl->type, base_type);
	} else {
		decl->type = base_type;
	}
	if (isnameoftype(base_type)) decl->flags |= DECL_REF;
}

/*
 * These are called before each Tcl interp is created (see
 * tclInterp.c) and after it is deleted.  Set up a top-level scope and
 * call frame in order to persist typedefs, struct types, and globals
 * across all the L programs compiled inside the interp.
 */
void
TclLInitCompiler(Tcl_Interp *interp)
{
	static Lglobal	global;  // L global state

//	putenv("MallocStackLogging=1");

	/* Associate the L interp state with this interp. */
	L = (Linterp *)ckalloc(sizeof(Linterp));
	memset(L, 0, sizeof(Linterp));
	Tcl_SetAssocData(interp, "L", TclLCleanupCompiler, L);

	L->global = &global;
	L->interp = interp;
	frame_push(NULL, NULL, OUTER|SEARCH);
	L_scope_enter();
	L->fn_calls = Tcl_NewObj();
	Tcl_SetVar2Ex(L->interp, "%%L_fnsCalled", NULL, L->fn_calls,
		      TCL_GLOBAL_ONLY);
	L->fn_decls = Tcl_NewObj();
	Tcl_SetVar2Ex(L->interp, "L_fnsDeclared", NULL, L->fn_decls,
		      TCL_GLOBAL_ONLY);
}

void
TclLCleanupCompiler(ClientData clientData, Tcl_Interp *interp)
{
	char	buf[32];

	L = (Linterp *)clientData;
	L_scope_leave();
	frame_pop();
	ast_free(L->ast_list);
	type_free(L->type_list);
	if (L->include_table) {
		Tcl_DeleteHashTable(L->include_table);
		ckfree((char *)L->include_table);
	}
	ckfree(L->file);
	ckfree(L->toplev);
	if (L->script) Tcl_DecrRefCount(L->script);
	ckfree((char *)L);
	L = NULL;

	snprintf(buf, sizeof(buf), "/usr/bin/leaks %u", getpid());
//	system(buf);
}

void
L_scope_enter()
{
	Scope	*new_scope = (Scope *)ckalloc(sizeof(*new_scope));

	new_scope->structs = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(new_scope->structs, TCL_STRING_KEYS);

	new_scope->typedefs = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(new_scope->typedefs, TCL_STRING_KEYS);

	new_scope->prev = L->curr_scope;
	L->curr_scope = new_scope;
}

void
L_scope_leave()
{
	Scope	*prev = L->curr_scope->prev;

	Tcl_DeleteHashTable(L->curr_scope->structs);
	ckfree((char *)L->curr_scope->structs);

	Tcl_DeleteHashTable(L->curr_scope->typedefs);
	ckfree((char *)L->curr_scope->typedefs);

	ckfree((char *)L->curr_scope);

	L->curr_scope = prev;
}

/*
 * Called by parser to look up a reference to "struct tag".  If
 * "local" is true, check only the current scope.  If the struct
 * hasn't yet been declared, add an incomplete type to the current
 * scope's struct table whose members will get filled up later when
 * the struct is fully declared.
 */
Type *
L_struct_lookup(char *tag, int local)
{
	int		new;
	Type		*type;
	Tcl_HashEntry	*hPtr = NULL;
	Scope		*scope;

	for (scope = L->curr_scope; !hPtr && scope; scope = scope->prev) {
		hPtr = Tcl_FindHashEntry(scope->structs, tag);
		if (local) break;
	}
	if (hPtr) {
		type = (Type *)Tcl_GetHashValue(hPtr);
	} else {
		hPtr = Tcl_CreateHashEntry(L->curr_scope->structs, tag, &new);
		type = type_mkStruct(tag, NULL);
		Tcl_SetHashValue(hPtr, type);
	}
	return (type);
}

/*
 * Called by parser to declare a new struct type.  If the struct
 * already has been declared but without any members, fill them in
 * now and return the existing type pointer.  If tag is NULL, just
 * sanity check the members' types (checking for void etc).
 */
Type *
L_struct_store(char *tag, VarDecl *m)
{
	Type	*type = NULL;

	ASSERT(m);

	if (tag) {
		type = L_struct_lookup(tag, TRUE);
		if (type->u.struc.members) {
			L_errf(m, "multiple declaration of struct %s", tag);
		} else {
			type->u.struc.members = m;
		}
	}

	/* Check member types for legality. */
	for (; m; m = m->next) {
		L_typeck_declType(m);
	}

	return (type);
}

/*
 * Called by parser to look up an ID in the typedef table to see if
 * it's been previously declared as a type name.
 */
Type *
L_typedef_lookup(char *name)
{
	Tcl_HashEntry	*hPtr = NULL;
	Scope		*scope;

	for (scope = L->curr_scope; !hPtr && scope; scope = scope->prev) {
		hPtr = Tcl_FindHashEntry(scope->typedefs, name);
	}
	if (hPtr) {
		return ((Type *)Tcl_GetHashValue(hPtr));
	} else {
		return (NULL);
	}
}

/*
 * Called by parser to define a new type name.
 */
void
L_typedef_store(VarDecl *decl)
{
	int		new;
	Tcl_HashEntry	*hPtr;
	Type		*new_type;
	char		*name = decl->id->str;

	hPtr = Tcl_CreateHashEntry(L->curr_scope->typedefs, name, &new);
	if (new) {
		new_type = type_dup(decl->type);
		if (new_type->name) ckfree(new_type->name);
		new_type->name = ckstrdup(name);
		Tcl_SetHashValue(hPtr, new_type);
	} else {
		Type *t = Tcl_GetHashValue(hPtr);
		unless (L_typeck_same(decl->type, t)) {
			L_errf(decl, "Cannot redefine type %s", name);
		}
	}
}

void
hash_put(Tcl_Obj *hash, char *key, char *val)
{
	Tcl_Obj	*keyObj, *valObj;

	ASSERT(hash && key);
	keyObj = Tcl_NewStringObj(key, -1);
	Tcl_IncrRefCount(keyObj);
	if (val) {
		valObj = Tcl_NewStringObj(val, -1);
	} else {
		valObj = *L_undefObjPtrPtr();
	}
	Tcl_DictObjPut(L->interp, hash, keyObj, valObj);
	Tcl_DecrRefCount(keyObj);
}

void
hash_rm(Tcl_Obj *hash, char *key)
{
	Tcl_Obj	*keyObj;

	ASSERT(hash && key);
	keyObj = Tcl_NewStringObj(key, -1);
	Tcl_IncrRefCount(keyObj);
	Tcl_DictObjRemove(L->interp, hash, keyObj);
	Tcl_DecrRefCount(keyObj);
}

char *
hash_get(Tcl_Obj *hash, char *key)
{
	int	ret;
	Tcl_Obj	*keyObj = Tcl_NewStringObj(key, -1);
	Tcl_Obj	*valObj;

	ASSERT(hash);
	Tcl_IncrRefCount(keyObj);
	ret = Tcl_DictObjGet(L->interp, hash, keyObj, &valObj);
	unless (ret == TCL_OK) return (NULL);
	Tcl_DecrRefCount(keyObj);
	if (valObj) {
		return (Tcl_GetString(valObj));
	} else {
		return (NULL);
	}
}

/* For debugging. */
void
hash_dump(Tcl_Obj *hash)
{
	int		done, ret;
	Tcl_Obj		*key, *val;
	Tcl_DictSearch	ctxt;

	ret = Tcl_DictObjFirst(L->interp, hash, &ctxt, &key, &val, &done);
	if ((ret != TCL_OK) || done) return;
	do {
		printf("%s -> %s\n", Tcl_GetString(key),
		       val->undef ? "<undef>" : Tcl_GetString(val));
		Tcl_DictObjNext(&ctxt, &key, &val, &done);
	} while (!done);
}

private char *
basenm(char *s)
{
	char	*t;

	for (t = s; *t; t++);
	do {
		t--;
	} while (*t != '/' && t > s);
	if (*t == '/') t++;
	return (t);
}

/*
 * Return the dirname of a path.  The caller must ckfree() it.
 */
char *
L_dirname(char *path)
{
	Tcl_Obj	*pathObj = Tcl_NewStringObj(path, -1);
	Tcl_Obj	*dirObj, *tmpObj;
	char	*ret = NULL;

	Tcl_IncrRefCount(pathObj);
	tmpObj = Tcl_FSGetNormalizedPath(NULL, pathObj);
	if (tmpObj == NULL) goto err;
	dirObj = TclPathPart(L->interp, tmpObj, TCL_PATH_DIRNAME);
	if (dirObj == NULL) goto err;
	ret = ckstrdup(Tcl_GetString(dirObj));
	Tcl_DecrRefCount(dirObj);
 err:	Tcl_DecrRefCount(pathObj);
	return (ret);
}

/*
 * This function executes the INST_L_SPLIT bytecode and is based on
 * pieces from tclCmdMZ.c.
 *
 * For edge cases, some of Perl's "split" semantics are obeyed:
 *
 * - A limit <= 0 means no limit.
 *
 * - Trailing null fields in the result are always suppressed.
 *
 * - If there is no delim, split on white space and trim any leading
 *   null fields from the result.
 *
 * - If the delim is /regexp/t, trim any leading null fields.
 *
 * - If all result fields are null, they are considered to be trailing
 *   and are all suppressed.
 */
Tcl_Obj *
L_split(Tcl_Interp *interp, Tcl_Obj *strobj, Tcl_Obj *delimobj,
	Tcl_Obj *limobj, Expr_f flags)
{
	int		chlen, i, leading, len, lim, matches, nocase, off, ret;
	int		trim = (flags & L_EXPR_RE_T);
	int		start = 0, end = 0;
	Tcl_RegExp	regExpr = NULL;
	Tcl_RegExpInfo	info;
	Tcl_Obj		**elems, *resultPtr, *objPtr, *listPtr;
	Tcl_UniChar	ch;
	char		*str;

	if (limobj) {
		Tcl_GetIntFromObj(interp, limobj, &lim);
		if (lim <= 0) {
			lim = INT_MAX;
		} else {
			/* The lim is the max # fields to return,
			 * which is one less than the max # matches to
			 * allow. */
			--lim;
		}
	} else {
		lim = INT_MAX;
	}

	/*
	 * Make sure to avoid problems where the objects are shared. This can
	 * cause RegExpObj <> UnicodeObj shimmering that causes data corruption.
	 * [Bug #461322]
	 */
	if (strobj == delimobj) {
		objPtr = Tcl_DuplicateObj(strobj);
	} else {
		objPtr = strobj;
	}
	if (objPtr->typePtr == &tclByteArrayType) {
		str = (char *)Tcl_GetByteArrayFromObj(objPtr, &len);
	} else {
		str = Tcl_GetStringFromObj(objPtr, &len);
	}

	listPtr = Tcl_NewObj();
	matches = 0;
	leading = 1;
	off     = 0;

	/*
	 * Split on white space if no delim was specified.
	 */
	unless (delimobj) {
		int skip = 0;
		for (start = 0; (off < len) && (matches < lim); off += chlen) {
			chlen = TclUtfToUniChar(str+off, &ch);
			if (skip) {
				unless (Tcl_UniCharIsSpace(ch)) {
					start   = off;
					skip    = 0;
					++matches;
				}
			} else {
				if (Tcl_UniCharIsSpace(ch)) {
					/* Suppress leading null field
					 * in result. */
					if (off || start) {
						resultPtr = Tcl_NewStringObj(
								str+start,
								off-start);
						Tcl_ListObjAppendElement(
								NULL, listPtr,
								resultPtr);
					}
					skip = 1;
				}
			}
		}
		unless (skip) {
			resultPtr = Tcl_NewStringObj(str+start, len-start);
			Tcl_ListObjAppendElement(NULL, listPtr, resultPtr);
		}
		goto done;
	}

	/*
	 * Split on a regular expression.
	 */
	nocase = (flags & L_EXPR_RE_I) ? TCL_REG_NOCASE : 0;
	regExpr = Tcl_GetRegExpFromObj(interp, delimobj,
				       TCL_REG_ADVANCED | TCL_REG_PCRE | nocase);
	unless (regExpr) {  // bad regexp
		listPtr = NULL;
		goto done;
	}
	while ((off < len) && (matches < lim)) {
		int	flags = TCL_REG_BYTEOFFSET;

		if ((off > 0) && (str[off-1] != '\n')) flags |= TCL_REG_NOTBOL;
		ret = Tcl_RegExpExecObj(interp, regExpr, objPtr, off, 1, flags);
		if (ret < 0) goto done;
		if (ret == 0) break;
		Tcl_RegExpGetInfo(regExpr, &info);
		start = info.matches[0].start;
		end   = info.matches[0].end;
		matches++;

		/*
		 * Copy to the result list the portion of the source
		 * string before the match. If we matched the empty
		 * string, split after the current char. Don't add
		 * leading null fields if specified.
		 */
		if (leading && trim && (start == 0)) {
			if (start == end) ++off;
			off += end;
			continue;
		}
		if (start == end) {
			ASSERT(start == 0);
			resultPtr = Tcl_NewStringObj(str+off, 1);
			++off;
		} else {
			resultPtr = Tcl_NewStringObj(str+off, start);
		}
		leading = 0;
		Tcl_ListObjAppendElement(NULL, listPtr, resultPtr);
		off += end;
	}
	/*
	 * Copy to the result list the portion of the source string after
	 * the last match, unless we matched the last char.
	 */
	if (off < len) {
		resultPtr = Tcl_NewStringObj(str+off, len-off);
		Tcl_ListObjAppendElement(NULL, listPtr, resultPtr);
	}

 done:
	if (objPtr && (strobj == delimobj)) {
		Tcl_DecrRefCount(objPtr);
	}
	unless (listPtr) return (NULL);

	/*
	 * Strip any trailing empty fields in the result.  This is
	 * to be consistent with Perl's split semantics.
	 */
	TclListObjGetElements(NULL, listPtr, &len, &elems);
	for (i = len-1; i >= 0; --i) {
		if (Tcl_GetCharLength(elems[i])) break;
		Tcl_ListObjReplace(interp, listPtr, i, 1, 0, NULL);
	}
	return (listPtr);
}

/*
 * This command splits the given arguments according to bash-style
 * quoting, returning a string[] array.
 *
 * xyz   -- all escapes are processed except \<newline> ignored
 * 'xyz' -- no single quotes allowed inside, no escapes processed
 * "xyz" -- only \\ and \" are processed, \<newline> ignored
 */
int
Tcl_ShSplitObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
	char	*cmd;
	int	i, j, len;
	Tcl_Obj	*arg = NULL, *argv;
	enum { LOOKING, ARG, SINGLE, DOUBLE } state;

	unless (objc >= 2) {
		Tcl_WrongNumArgs(interp, 1, objv, "string ?string ...?");
		return (TCL_ERROR);
	}
	argv = Tcl_NewObj();
	for (i = 1; i < objc; ++i) {
		cmd = TclGetStringFromObj(objv[i], &len);
		state = LOOKING;
		for (j = 0; j < len; ++j) {
			char c = cmd[j];
			switch (state) {
			    case LOOKING:
				if (isspace(c)) {
					continue;
				} else {
					arg = Tcl_NewObj();
					state = ARG;
					/*FALLTHRU*/
				}
			    case ARG:
				if (isspace(c)) {
					Tcl_ListObjAppendElement(interp,
								 argv, arg);
					state = LOOKING;
				} else if (c == '\\') {
					char	e = 0;
					if ((j+1) < len) e = cmd[j+1];
					// escape anything but ignore \<newline>
					if (!e) {
						Tcl_AppendResult(interp,
								 "trailing \\",
								 NULL);
						return (TCL_ERROR);
					} else if (e == '\n') {
						++j;
					} else {
						Tcl_AppendToObj(arg, &e, 1);
						++j;
					}
				} else if (c == '\'') {
					state = SINGLE;
				} else if (c == '"') {
					state = DOUBLE;
				} else {
					Tcl_AppendToObj(arg, &c, 1);
				}
				break;
			    case SINGLE:
				if (c == '\'') {
					state = ARG;
				} else {
					Tcl_AppendToObj(arg, &c, 1);
				}
				break;
			    case DOUBLE:
				if (c == '\\') {
					char	e = 0;
					if ((j+1) < len) e = cmd[j+1];
					// escape \ and " but ignore \<newline>
					if ((e == '\\') || (e == '"')) {
						Tcl_AppendToObj(arg, &e, 1);
						++j;
					} else if (e == '\n') {
						++j;
					} else {
						Tcl_AppendToObj(arg, &c, 1);
					}
				} else if (c == '"') {
					state = ARG;
				} else {
					Tcl_AppendToObj(arg, &c, 1);
				}
				break;
			}
		}
		switch (state) {
		    case LOOKING:
			break;
		    case ARG:
			Tcl_ListObjAppendElement(interp, argv, arg);
			break;
		    case SINGLE:
			Tcl_AppendResult(interp, "unterminated \'", NULL);
			return (TCL_ERROR);
		    case DOUBLE:
			Tcl_AppendResult(interp, "unterminated \"", NULL);
			return (TCL_ERROR);
		}
	}
	Tcl_SetObjResult(interp, argv);
	return (TCL_OK);
}

int
Tcl_GetOptObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
	int		ac, i, n, ret = TCL_OK;
	char		**av, *opts, *s;
	longopt		*lopts = NULL;
	Tcl_Obj		**objs;

	/*
	 * This is all about converting the L args to C args for the
	 * getopt() call and then mapping back for the return value.
	 */

	unless (objc == 4) {
		Tcl_WrongNumArgs(interp, 1, objv, "av opts lopts");
		return (TCL_ERROR);
	}

	/* Set the C optind variable from its L counterpart. */
	s = (char *)Tcl_GetVar(interp, "optind", TCL_GLOBAL_ONLY);
	if (s) optind = atoi(s);

	if (Tcl_ListObjGetElements(interp, objv[1], &ac, &objs) != TCL_OK) {
		return (TCL_ERROR);
	}
	av = (char **)ckalloc(ac * sizeof(char *));
	for (i = 0; i < ac; ++i) {
		av[i] = TclGetString(objs[i]);
	}
	opts = (objv[2]->undef ? "" : TclGetString(objv[2]));
	/*
	 * For long opts, the C API wants an array of <char*,int>, and
	 * the L call sent in a string array, so map the long opt name to
	 * its L array index + 300 (values <= 256 are reserved for the
	 * short opts and GETOPT_ERR).
	 */
	if (Tcl_ListObjGetElements(interp, objv[3], &n, &objs) != TCL_OK) {
		ret = TCL_ERROR;
		goto done;
	}
	if (n) {
		lopts = (longopt *)ckalloc((n+1) * sizeof(longopt));
		for (i = 0; i < n; ++i) {
			lopts[i].name = TclGetString(objs[i]);
			lopts[i].ret  = 300 + i;
		}
		lopts[i].name = NULL;
	}
	i = getopt(ac, av, opts, lopts);
	switch (i) {
	    case GETOPT_EOF:
		Tcl_SetObjResult(interp, *L_undefObjPtrPtr());
		break;
	    case GETOPT_ERR:
		Tcl_SetObjResult(interp, Tcl_NewStringObj("", 0));
		break;
	    default:
		if (i < 300) {
			// short opt
			char str[1];
			str[0] = i;
			Tcl_SetObjResult(interp, Tcl_NewStringObj(str, 1));
		} else {
			// long opt -- map back to the longopts array entry
			// and strip any trailing :;|
			s = TclGetStringFromObj(objs[i-300], &n);
			if ((s[n-1] == ':') || (s[n-1] == ';') ||
			    (s[n-1] == '|')) {
				Tcl_SetObjResult(interp,
						 Tcl_NewStringObj(s,n-1));
			} else {
				Tcl_SetObjResult(interp, objs[i-300]);
			}
		}
		break;
	}
	/* Set the optind, optopt, and optarg globals from the C variables. */
	s = cksprintf("%d", optind);
	Tcl_SetVar(interp, "optind", s, TCL_GLOBAL_ONLY);
	ckfree(s);
	s = cksprintf("%c", optopt);
	Tcl_SetVar(interp, "optopt", s, TCL_GLOBAL_ONLY);
	ckfree(s);
	if (optarg) {
		Tcl_SetVar(interp, "optarg", optarg, TCL_GLOBAL_ONLY);
	} else {
		Tcl_SetVar2Ex(interp, "optarg", NULL, *L_undefObjPtrPtr(),
			      TCL_GLOBAL_ONLY);
	}
 done:
	ckfree((char *)av);
	ckfree((char *)lopts);
	return (ret);
}

int
Tcl_GetOptResetObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
	unless (objc == 1) {
		Tcl_WrongNumArgs(interp, 1, objv, NULL);
		return (TCL_ERROR);
	}
	getoptReset();
	Tcl_SetVar(interp, "optind", "0", TCL_GLOBAL_ONLY);
	Tcl_SetVar(interp, "optopt", "", TCL_GLOBAL_ONLY);
	Tcl_SetVar2Ex(interp, "optarg", NULL, *L_undefObjPtrPtr(),
		      TCL_GLOBAL_ONLY);
	return (TCL_OK);
}

/*
 * Parts of the next two functions are taken from Tcl_GetsObjCmd().
 * do_getline() is like Tcl_GetsObjCmd() except that it results in
 * undef on error or EOF, and it returns the result object so you
 * don't have to pull it out of the interp to see what happened.
 */

private Tcl_Obj *
do_getline(Tcl_Interp *interp, Tcl_Channel chan)
{
	Tcl_Obj	*ret;

	ret = Tcl_NewObj();
	if (Tcl_GetsObj(chan, ret) < 0) {
		Tcl_DecrRefCount(ret);
		if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
			/*
			 * TIP #219. Capture error messages put by the
			 * driver into the bypass area and put them
			 * into the regular interpreter result.  Fall
			 * back to the regular message if nothing was
			 * found in the bypass.
			 */
			if (!TclChanCaughtErrorBypass(interp, chan)) {
				Tcl_ResetResult(interp);
				Tcl_AppendResult(interp, Tcl_PosixError(interp),
						 NULL);
			}
			Tcl_SetVar2Ex(interp, "::stdio_lasterr", NULL,
				      Tcl_GetObjResult(interp),
				      TCL_GLOBAL_ONLY);
			return (NULL);
		}
		ret = *L_undefObjPtrPtr();
	}
	Tcl_SetObjResult(interp, ret);
	return (ret);
}

int
Tcl_FGetlineObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
	int		mode;
	Tcl_Channel	chan;

	if (objc != 2) {
		Tcl_WrongNumArgs(interp, 1, objv, "channelId");
		return (TCL_ERROR);
	}
	if (TclGetChannelFromObj(interp, objv[1], &chan,
				 &mode, 0) != TCL_OK) {
		goto err;
	}
	unless (mode & TCL_READABLE) {
		Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]),
				 "\" wasn't opened for reading", NULL);
		goto err;
	}
	unless (do_getline(interp, chan)) {
		goto err;
	}
	return (TCL_OK);
 err:
	Tcl_SetVar2Ex(interp, "::stdio_lasterr", NULL,
		      Tcl_GetObjResult(interp),
		      TCL_GLOBAL_ONLY);
	Tcl_SetObjResult(interp, *L_undefObjPtrPtr());
	return (TCL_OK);
}

int
Tcl_LAngleReadObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
	Tcl_Obj			*ret = NULL;
	int			argc, res;
	Tcl_Obj			**argv;
	static int		cur = 0;
	static Tcl_Channel	chan = NULL;

	if (objc != 1) {
		Tcl_WrongNumArgs(interp, 1, objv, NULL);
		return (TCL_ERROR);
	}
	unless (L->global->script_argc) {
		Tcl_Obj	*objv[2];

		objv[0] = Tcl_NewStringObj("angle_read_", -1);
		objv[1] = Tcl_NewStringObj("stdin", -1);
		res = Tcl_FGetlineObjCmd(dummy, interp, 2, objv);
		Tcl_DecrRefCount(objv[0]);
		Tcl_DecrRefCount(objv[1]);
		return (res);
	}
	Tcl_ListObjGetElements(L->interp, L->global->script_argv, &argc, &argv);
	while (1) {
		if (chan) {
			ret = do_getline(interp, chan);
			if (ret && !ret->undef) break;
			Tcl_UnregisterChannel(interp, chan);
			chan = NULL;
		}
		if (cur >= argc) {
			Tcl_SetObjResult(interp, *L_undefObjPtrPtr());
			break;
		}
		chan = Tcl_FSOpenFileChannel(interp, argv[cur++], "r", 0);
		if (chan) {
			Tcl_RegisterChannel(interp, chan);
		} else {
			fprintf(stderr, "%s\n", Tcl_GetStringResult(interp));
			Tcl_ResetResult(interp);
		}
	}
	return (TCL_OK);
}

extern int Tcl_WriteObjN(Tcl_Channel chan, Tcl_Obj *objPtr, int numBytes);

int
Tcl_LWriteCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
	int		mode, nbytes;
	char		*errmsg = "";
	Tcl_Channel	chan;

	if (objc != 4) {
		Tcl_WrongNumArgs(interp, 1, objv, "channel buffer numBytes");
		return (TCL_ERROR);
	}
	if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) {
		return (TCL_ERROR);
	}
	if (!(mode & TCL_WRITABLE)) {
		errmsg = "channel wasn't opened for writing";
		goto err;
	}
	if (Tcl_GetIntFromObj(interp, objv[3], &nbytes) != TCL_OK) {
		return (TCL_ERROR);
	}
	nbytes = Tcl_WriteObjN(chan, objv[2], nbytes);
	if (nbytes < 0) {
		if (!TclChanCaughtErrorBypass(interp, chan)) {
			errmsg = (char *)Tcl_PosixError(interp);
		}
		goto err;
	}
 out:
	Tcl_SetObjResult(interp, Tcl_NewIntObj(nbytes));
	return (TCL_OK);
 err:
	Tcl_SetVar2(interp, "::stdio_lasterr", NULL, errmsg, TCL_GLOBAL_ONLY);
	nbytes = -1;
	goto out;
}

int
Tcl_LReadCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
	int		mode, nbytes = -1;
	char		*errmsg = "";
	Tcl_Channel	chan;
	Tcl_Obj		*buf;

	if ((objc != 4) && (objc != 3)) {
		Tcl_WrongNumArgs(interp, 1, objv, "channel varName ?numBytes");
		return (TCL_ERROR);
	}
	if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) {
		return (TCL_ERROR);
	}
	if (!(mode & TCL_READABLE)) {
		errmsg = "channel wasn't opened for reading";
		goto err;
	}
	if (Tcl_Eof(chan)) {
		errmsg = "end of file";
		goto err;
	}
	if (objc == 4) {
		if (Tcl_GetIntFromObj(interp, objv[3], &nbytes) != TCL_OK) {
			return (TCL_ERROR);
		}
	}
	buf = Tcl_NewObj();
	Tcl_IncrRefCount(buf);
	nbytes = Tcl_ReadChars(chan, buf, nbytes, 0);
	if (nbytes < 0) {
		if (!TclChanCaughtErrorBypass(interp, chan)) {
			errmsg = (char *)Tcl_PosixError(interp);
		}
		Tcl_DecrRefCount(buf);
		goto err;
	}
	Tcl_ObjSetVar2(interp, objv[2], NULL, buf, TCL_LEAVE_ERR_MSG);
	Tcl_DecrRefCount(buf);
	Tcl_SetObjResult(interp, Tcl_NewIntObj(nbytes));
	return (TCL_OK);
 err:
	Tcl_SetVar(interp, "::stdio_lasterr", errmsg, TCL_GLOBAL_ONLY);
	Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
	return (TCL_OK);
}

int
Tcl_LRefCnt(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
	if (objc != 2) {
		Tcl_WrongNumArgs(interp, 1, objv, "object");
		return (TCL_ERROR);
	}
	Tcl_SetObjResult(interp, Tcl_NewIntObj(objv[1]->refCount));
	return (TCL_OK);
}

/*
 * This defines a defined() proc even though it also is a compiler
 * built-in.  When L code uses defined(), it gets the built-in.
 * Having the proc allows access to this functionality from Tcl code.
 */
int
Tcl_LDefined(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
	if (objc != 2) {
		Tcl_WrongNumArgs(interp, 1, objv, "object");
		return (TCL_ERROR);
	}
	Tcl_SetObjResult(interp, Tcl_NewIntObj(objv[1]->undef ? 0 : 1));
	return (TCL_OK);
}

/*
 * This evaluates an Lhtml document.  All input is passed through
 * to Tcl's stdout channel with two kinds of interpolation:
 *
 * - Anything between <? and ?> is taken to be L statements
 *   and is replaced by whatever that L code outputs.
 *
 * - Anything between <?= and ?> is taken to be an L expression and is
 *   replaced by whatever it evaluates to (this is just like regular L
 *   string interpolation).
 *
 * This works by putting the scanner into an Lhtml mode where
 * <?, <?=, and ?> are recognized. The parser contains rules for
 * wrapping the html in puts() calls.
 */
int
Tcl_LHtmlObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
	int	ret;

	L_lex_begLhtml();
	ret = Tcl_LObjCmd(NULL, interp, objc, objv);
	L_lex_endLhtml();
	return (ret);
}

/*
 * A Tcl_Obj type to store a pointer into a string buffer that we can
 * walk down over time.  The twpPtrValue internalrep is used, with the
 * first ptr pointing to a ckalloc'd Bufptr struct (defined below) and
 * the second ptr pointing to a copy of the buffer.
 */
static Tcl_ObjType L_bufPtrType = {
    "l-bufPtrType",
    NULL,			/* freeIntRepProc */
    NULL,			/* dupIntRepProc */
    NULL,			/* updateStringProc */
    NULL			/* setFromAnyProc */
};
typedef struct {
	char	*p;
	char	*end;
} Bufptr;

int
Tcl_LGetNextLineInit(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
	int	len;
	char	*beg, *s;
	Tcl_Obj	*tmp;
	Bufptr	*bufptr;

	if (objc != 2) {
		Tcl_WrongNumArgs(interp, 1, objv, "object");
		return (TCL_ERROR);
	}
	if (objv[1]->undef) {
		Tcl_SetObjResult(interp, *L_undefObjPtrPtr());
		return (TCL_OK);
	}

	/*
	 * Make a copy of the string whose lines we will walk.  Do
	 * this instead of copying the Tcl_Obj to avoid problems with
	 * possible shimmering (i.e., the Tcl_Obj's string-rep buffer is
	 * not guaranteed to remain).
	 */
	s = Tcl_GetStringFromObj(objv[1], &len);
	beg = ckalloc(len + 1);
	memcpy(beg, s, len);
	beg[len] = '\0';

	/*
	 * Stash the copied string and a Bufptr into it inside of a
	 * tmp Tcl_Obj that will live for the duration of the walk.
	 * Tcl_LGetNextLine() will process it.
	 */
	tmp = Tcl_NewObj();
	tmp->typePtr = &L_bufPtrType;
	bufptr = (Bufptr *)ckalloc(sizeof(Bufptr));
	bufptr->p   = beg;
	bufptr->end = beg + len;
	tmp->internalRep.twoPtrValue.ptr1 = bufptr;
	tmp->internalRep.twoPtrValue.ptr2 = beg;

	Tcl_SetObjResult(interp, tmp);
	return (TCL_OK);
}

int
Tcl_LGetNextLine(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
	Tcl_Obj	*ret, *tmp;
	char	*beg, *p;
	Bufptr	*bufptr;

	if (objc != 2) {
		Tcl_WrongNumArgs(interp, 1, objv, "tmp");
		return (TCL_ERROR);
	}
	tmp = objv[1];
	if (tmp->undef) goto nomore;
	unless (tmp->typePtr == &L_bufPtrType) {
		Tcl_SetObjResult(interp,
				 Tcl_NewStringObj("invalid tmp object", -1));
		return (TCL_ERROR);
	}
	bufptr = (Bufptr *)tmp->internalRep.twoPtrValue.ptr1;
	unless (bufptr) goto nomore;

	beg = bufptr->p;
	if (beg >= bufptr->end) goto nomore;

	for (p = beg; p < bufptr->end; ++p) {
		if (p[0] == '\n') {
			bufptr->p = p + 1;
			break;
		}
		if (((p+1) < bufptr->end) && (p[0] == '\r') && (p[1] == '\n')) {
			bufptr->p = p + 2;
			break;
		}
	}
	ret = Tcl_NewStringObj(beg, p - beg);
	if (p == bufptr->end) {
		ckfree(tmp->internalRep.twoPtrValue.ptr2);
		ckfree((char *)bufptr);
		tmp->internalRep.twoPtrValue.ptr1 = NULL;
		tmp->internalRep.twoPtrValue.ptr2 = NULL;
	}
	Tcl_SetObjResult(interp, ret);
	return (TCL_OK);
 nomore:
	Tcl_SetObjResult(interp, *L_undefObjPtrPtr());
	return (TCL_OK);
}

#ifdef _WIN32

int
Tcl_LGetDirX(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
	int		len, ret;
	Tcl_Obj		*argv[2], *dirObjs, *eltObjs[3], *fileObjs, *listObj;
	char		*buf, *dir, *type, *utfname;
	Tcl_DString	ds;
	HANDLE		hFind;
	WIN32_FIND_DATA	f;

	if (objc != 2) {
		Tcl_WrongNumArgs(interp, 1, objv, "directory");
		return (TCL_ERROR);
	}

	// Append \* to the given directory path.
	dir = cksprintf("%s\\*", Tcl_GetString(objv[1]));
	Tcl_WinUtfToTChar(dir, -1, &ds);

	hFind = FindFirstFile((TCHAR *)Tcl_DStringValue(&ds), &f);
	if (hFind == INVALID_HANDLE_VALUE) {
		TclWinConvertError(GetLastError());
		FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER |
			       FORMAT_MESSAGE_FROM_SYSTEM |
			       FORMAT_MESSAGE_IGNORE_INSERTS,
			       NULL,
			       GetLastError(),
			       MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
			       (char *)&buf,
			       0, NULL);
		// Chomp the cr,lf that windows added to buf.
		len = strlen(buf);
		if (len > 2) buf[len-2] = 0;
		Tcl_SetVar(interp, "::stdio_lasterr",
			   buf,
			   TCL_GLOBAL_ONLY);
		Tcl_SetObjResult(interp, *L_undefObjPtrPtr());
		LocalFree(buf);
		return (TCL_OK);
	}
	ckfree(dir);
	Tcl_DStringFree(&ds);

	fileObjs = Tcl_NewListObj(0, NULL);
	dirObjs  = Tcl_NewListObj(0, NULL);
	do {
		utfname = Tcl_WinTCharToUtf(f.cFileName, -1, &ds);
		eltObjs[0] = Tcl_NewStringObj(utfname, -1);
		if (f.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) {
			type = "directory";
		} else {
			type = "file";
		}
		eltObjs[1] = Tcl_NewStringObj(type, -1);
		if ((f.dwFileAttributes & FILE_ATTRIBUTE_HIDDEN) ||
		    (*utfname == '.')) {
			eltObjs[2] = Tcl_NewIntObj(1);
		} else {
			eltObjs[2] = Tcl_NewIntObj(0);
		}
		listObj = Tcl_NewListObj(3, eltObjs);
		if (f.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) {
			Tcl_ListObjAppendElement(interp, dirObjs, listObj);
		} else {
			Tcl_ListObjAppendElement(interp, fileObjs, listObj);
		}
		Tcl_DStringFree(&ds);
	} while (FindNextFile(hFind, &f));
	FindClose(hFind);

	// Sort the lists.
	argv[1] = dirObjs;
	Tcl_IncrRefCount(dirObjs);
	Tcl_ResetResult(interp);
	ret = Tcl_LsortObjCmd(NULL, interp, 2, argv);
	Tcl_DecrRefCount(dirObjs);
	if (ret == TCL_OK) {
		dirObjs = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
	}

	argv[1] = fileObjs;
	Tcl_IncrRefCount(fileObjs);
	Tcl_ResetResult(interp);
	ret = Tcl_LsortObjCmd(NULL, interp, 2, argv);
	Tcl_DecrRefCount(fileObjs);
	if (ret == TCL_OK) {
		fileObjs = Tcl_GetObjResult(interp);
	}

	// Return a list with the file names after all the dir names.
	Tcl_ListObjAppendList(interp, dirObjs, fileObjs);
	Tcl_SetObjResult(interp, dirObjs);
	return (TCL_OK);
}

#else  // #ifdef WIN32

int
Tcl_LGetDirX(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
	int		ret;
	Tcl_Obj		*argv[2], *dirObjs, *eltObjs[3], *fileObjs, *listObj;
	DIR		*d;
	struct dirent	*dent;
	char		*dir, *type;
#ifndef HAVE_STRUCT_DIRENT_D_TYPE
	char		*path;
	struct stat	st;
#endif

	if (objc != 2) {
		Tcl_WrongNumArgs(interp, 1, objv, "directory");
		return (TCL_ERROR);
	}

	dir = Tcl_GetString(objv[1]);
	d = opendir(dir);
	unless (d) {
		Tcl_SetVar(interp, "::stdio_lasterr",
			   strerror(errno),
			   TCL_GLOBAL_ONLY);
		Tcl_SetObjResult(interp, *L_undefObjPtrPtr());
		return (TCL_OK);
	}

	fileObjs = Tcl_NewListObj(0, NULL);
	dirObjs  = Tcl_NewListObj(0, NULL);
	while (dent = readdir(d)) {
		eltObjs[0] = Tcl_NewStringObj(dent->d_name, -1);
#ifdef HAVE_STRUCT_DIRENT_D_TYPE
		switch (dent->d_type) {
		    case DT_REG: type = "file";      break;
		    case DT_DIR: type = "directory"; break;
		    default:     type = "other";     break;
		}
#else
		path = cksprintf("%s/%s", dir, dent->d_name);
		if (stat(path, &st)) {
			type = "unknown";
		} else if (S_ISREG(st.st_mode)) {
			type = "file";
		} else if (S_ISDIR(st.st_mode)) {
			type = "directory";
		} else {
			type = "other";
		}
		ckfree(path);
#endif
		eltObjs[1] = Tcl_NewStringObj(type, -1);
		if (*dent->d_name == '.') {
			eltObjs[2] = Tcl_NewIntObj(1);
		} else {
			eltObjs[2] = Tcl_NewIntObj(0);
		}
		listObj = Tcl_NewListObj(3, eltObjs);
		if (*type == 'd') {
			Tcl_ListObjAppendElement(interp, dirObjs, listObj);
		} else {
			Tcl_ListObjAppendElement(interp, fileObjs, listObj);
		}
	}
	closedir(d);

	// Sort the lists.
	argv[1] = dirObjs;
	Tcl_IncrRefCount(dirObjs);
	Tcl_ResetResult(interp);
	ret = Tcl_LsortObjCmd(NULL, interp, 2, argv);
	Tcl_DecrRefCount(dirObjs);
	if (ret == TCL_OK) {
		dirObjs = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
	}

	argv[1] = fileObjs;
	Tcl_IncrRefCount(fileObjs);
	Tcl_ResetResult(interp);
	ret = Tcl_LsortObjCmd(NULL, interp, 2, argv);
	Tcl_DecrRefCount(fileObjs);
	if (ret == TCL_OK) {
		fileObjs = Tcl_GetObjResult(interp);
	}

	// Return a list with the file names after all the dir names.
	Tcl_ListObjAppendList(interp, dirObjs, fileObjs);
	Tcl_SetObjResult(interp, dirObjs);
	return (TCL_OK);
}

#endif  // #ifdef WIN32
